ADA Programming Guide/ADA Programming Guide.iso/adatutor/csparts/cspartb3.src

Text File | 1996-01-30 | 161KB | 5,206 lines

--::::::::::
--hashmap.bdy
--::::::::::
-- $Source: /nosc/work/abstractions/mapping/RCS/hash_map.bdy,v $
-- $Revision: 1.3 $ -- $Date: 85/02/01 14:48:43 $ -- $Author: ron $

with unchecked_deallocation;

package body hashed_mapping_pkg is

    function equal(c1, c2: component)
    return boolean is
    begin
    return equal(c1.key, c2.key);
    end equal;


  -- Utilities:

    procedure free is new unchecked_deallocation(mapping_rec, mapping);

    function make_general_iter(map: mapping)
    return general_iter;
      --| Raises: uninitialized_mapping
      --| Effects:
      --| Create and return a general iterator based on map.  Sets up
      --| map, current and position fields as in the spec.
      --| Raises uninitialized_mapping iff map has not been initialized.

    function more(iter: general_iter)
    return boolean;
      --| Effects:
      --| Returns true iff the general iter has not been exhausted, i.e.,
      --| returns not IsEmpty(iter.position).

    procedure advance(iter: in out general_iter);
      --| Effects:
      --| Advances iter.position, and if necessary, iter.current to the
      --| next component, as detailed in the spec.  iter.position will
      --| be empty if no more elements remain to be iterated over.
      --| Requires:
      --| iter.position is not null, i.e., caller has determined that iter
      --| was not exhausted before calling advance.


  -- Constructors:

    function create
        return mapping is
        m: mapping;
    begin
        -- deleted because of Decada bug:
--      return new mapping_rec'(size => 0,
--                              buckets => (bucket_range => create));
        m := new mapping_rec;
        m.size := 0;
        m.all.buckets := (bucket_array'range => create);
        return m;
    end create;

    procedure bind(map:   in out mapping;
                   key:   in     key_type;
                   value: in     value_type) is
    idx: bucket_range := hash(key);
    c: component := (key => key, val => value);
    begin
    if IsInList(map.buckets(idx), c) then
        raise already_bound;
    end if;

    map.buckets(idx) := attach(c, map.buckets(idx));
    map.size := map.size + 1;

    exception
        when constraint_error =>       -- null dereference
        raise uninitialized_mapping;
    end bind;

    procedure unbind(map: in out mapping;
                     key: in     key_type) is
    idx: bucket_range := hash(key);
    tmpc: component;
    begin
    tmpc.key := key;   -- don't need a value, equality just tests keys
    DeleteItem(map.buckets(idx), tmpc);
    map.size := map.size - 1;

    exception
        when ItemNotPresent =>
            raise not_bound;
    when constraint_error =>       -- null dereference
        raise uninitialized_mapping;
    end unbind;

    function copy(map: mapping)
    return mapping is
    new_map: mapping;
    begin
    if map = null then raise uninitialized_mapping; end if;

    new_map := new mapping_rec;
    new_map.size := map.size;
    for idx in bucket_range loop
        new_map.buckets(idx) := copy(map.buckets(idx));
    end loop;
    return new_map;
    end copy;


  -- Query Operations:

    function is_empty(map: mapping)
        return boolean is
    begin
    return map.size = 0;
    exception
    when constraint_error =>       -- null dereference
        raise uninitialized_mapping;
    end is_empty;

    function size(map: mapping)
        return natural is
    begin
    return map.size;
    exception
    when constraint_error =>       -- null dereference
        raise uninitialized_mapping;
    end size;

    function is_bound(map: mapping;
                      key: key_type)
    return boolean is
    tmpc: component;
    begin
    tmpc.key := key;   -- don't need a value, equality just tests keys
    return IsInList(map.buckets(hash(key)), tmpc);
    exception
        when constraint_error =>     -- null dereference
        raise uninitialized_mapping;
    end is_bound;

    function fetch(map: mapping;
                   key: key_type)
    return value_type is
    buck: list;
    begin
    buck := map.buckets(hash(key));

    while not IsEmpty(buck) loop
            if equal(key, FirstValue(buck).key) then
        return FirstValue(buck).val;
        end if;
        buck := tail(buck);
    end loop;
    raise not_bound;

    exception
    when constraint_error =>       -- null dereference
        raise uninitialized_mapping;
    end fetch;


  -- Iterators:

    function make_keys_iter(map: mapping)
        return keys_iter is
    begin
    return keys_iter(make_general_iter(map));
    end make_keys_iter;

    function more(iter: keys_iter)
        return boolean is
    begin
    return more(general_iter(iter));
    end more;

    procedure next(iter: in out keys_iter;
                   key:  out    key_type) is
    begin
    key := FirstValue(iter.position).key;
    advance(general_iter(iter));
    exception
        when EmptyList =>
        raise no_more;
    end next;

    function make_values_iter(map: mapping)
    return values_iter is
    begin
    return values_iter(make_general_iter(map));
    end make_values_iter;

    function more(iter: values_iter)
    return boolean is
    begin
    return more(general_iter(iter));
    end more;

    procedure next(iter: in out values_iter;
           val:  out    value_type) is
    begin
    val := FirstValue(iter.position).val;
    advance(general_iter(iter));
    exception
        when EmptyList =>
        raise no_more;
    end next;

    function make_bindings_iter(map: mapping)
    return bindings_iter is
    begin
        return bindings_iter(make_general_iter(map));
    end make_bindings_iter;

    function more(iter: bindings_iter)
    return boolean is
    begin
    return more(general_iter(iter));
    end more;

    procedure next(iter: in out bindings_iter;
           key:  out    key_type;
           val:  out    value_type) is
    comp: component;
    begin
    comp := FirstValue(iter.position);
    key := comp.key;
    val := comp.val;
    advance(general_iter(iter));
    exception
        when EmptyList =>
        raise no_more;
    end next;


  -- Heap management:

    procedure destroy(m: in out mapping) is
    begin
        for i in bucket_range loop
            destroy(m.buckets(i));
        end loop;
        free(m);
    exception
        when constraint_error =>    -- m is null
        return;
    end destroy;


-- Utilities:

    function make_general_iter(map: mapping)
    return general_iter is
    iter: general_iter;
    begin
    if map = null then raise uninitialized_mapping; end if;

    for idx in bucket_range loop
        if not IsEmpty(map.buckets(idx)) then
        iter.map := map;
        iter.current := idx;
        iter.position := map.buckets(idx);
        return iter;
        end if;
    end loop;

    iter.position := create;   -- no elements, makes next(iter) false.
    return iter;
    end make_general_iter;

    function more(iter: general_iter)
    return boolean is
    begin
    return not IsEmpty(iter.position);
    end more;

    procedure advance(iter: in out general_iter) is
    begin
    iter.position := tail(iter.position);
        if IsEmpty(iter.position) and then iter.current /= bucket_range'last then
        for idx in iter.current + 1..bucket_range'last loop
        if not IsEmpty(iter.map.buckets(idx)) then
            iter.current := idx;
            iter.position := iter.map.buckets(idx);
            return;
        end if;
        end loop;
        end if;
        -- At this point, IsEmpty(iter.position) => not more(iter)
    end advance;

end hashed_mapping_pkg;
--::::::::::
--ltrees.bdy
--::::::::::
with unchecked_deallocation;
package body Labeled_Trees is

----------------------------------------------------------------------------
--                   Local Subprograms
----------------------------------------------------------------------------

procedure Free is new unchecked_deallocation (Node, Tree);

function equal (
       X :in     Label_Type;
       Y :in     Label_Type
) return boolean is

begin
    return (not (X < Y))  and  (not (Y < X));
end equal;

------------------------------------------------------------------------------

procedure Internal_Is_Label_In_Tree (
   T         :in      Tree;
   L         :in      Label_Type;
   Parent    :in out Tree;
   Present   :   out boolean;
   recursed  :in out boolean
) is
begin
    --| OVERVIEW
    --| This procedure is used so that
    --| Is_Label_In_Tree (T, L, Subtree, Present) returns more useful
    --| information.  If the label L is not in the tree then Subtree is
    --| the root of the tree where L should be inserted.  If L is in
    --| the tree then Subtree is the root of the tree where L is.
    --| This procedure is necessary because in Is_Label_In_Tree has Subtree
    --| as an out parameter not as in out.

    --| The variable Recursed is used to indicate whether we have called
    --| the procedure recursively.  It is used when T is null.  If T is
    --| null and we haven't called recursively then T's parent is null.
    --| If T is null and we have called the procedure recusively then
    --| T's parent is not null.

    if T = null then
        Present := false;
        if not Recursed then
            Parent := null;
        end if;
    elsif L < T.Label then
        Parent := T;
        recursed := true;
        Internal_Is_Label_In_Tree (T.Left_Child, L, Parent, Present, Recursed);
    elsif T.Label < L then
        Parent := T;
        Recursed := true;
        Internal_Is_Label_In_Tree (
          T.Right_Child , L, Parent, Present, Recursed
                                  );
    else
        Parent := T;
        Present := true;
    end if;
end Internal_Is_Label_In_Tree;

------------------------------------------------------------------------------

function Pre_Order_Generate (
          T :in Tree
) return  Node_Order.List is


--| This routine generates a list of pointers to nodes in the tree t.
--| The list of nodes is a pre order list of the nodes of the tree.

    L : Node_Order.List;
begin
    L := Node_Order.Create;
    if T /= null then
        Node_Order.Attach (L, T);
        Node_Order.Attach (L, Pre_Order_Generate (T.Left_Child));
        Node_Order.Attach (L, Pre_Order_Generate (T.Right_Child));
    end if;
    return L;
end Pre_Order_Generate;

------------------------------------------------------------------------------

function Post_Order_Generate (
          T :in Tree
) return  Node_Order.List is


--| This routine generates a list of pointers to nodes in the tree t.
--| The list is a post ordered list of nodes of the tree.

    L : Node_Order.List;
begin
    L := Node_Order.Create;
    if T /= null then
        L := Post_Order_Generate (T.Left_Child);
        Node_Order.Attach (L, Post_Order_Generate (T.Right_Child));
        Node_Order.Attach (L, T);
    end if;
    return L;
end Post_Order_Generate;

------------------------------------------------------------------------------

function In_Order_Generate (
          T :in Tree
) return  Node_Order.List is


--| This routine generates a list of pointers to nodes in the tree t.
--| The list is ordered with respect to the order of the nodes in the tree.
--| The nodes in the list are such the element 1 < element 2 < ....
--| element (n - 1) < element (n).  Where < is passed in .

    L : Node_Order.List;
begin
    L := Node_Order.Create;
    if T /= null then
        L := In_Order_Generate (T.Left_Child);
        Node_Order.Attach (L, T);
        Node_Order.Attach (L, In_Order_Generate (T.Right_Child));
    end if;
    return L;
end In_Order_Generate;

------------------------------------------------------------------------------



------------------------------------------------------------------------------
--                    Visible Subprograms
------------------------------------------------------------------------------

------------------------------------------------------------------------------

function Create  return Tree is

begin
    return null;
end;

------------------------------------------------------------------------------

procedure Destroy_Deep_Tree (
  T :in out Tree
) is

begin
    --| ALGORITHM
    --| Walk over the tree destroying the value, the label, and then the node
    --| itself.  Do this in post order.  This means destroy the left child
    --| destroy the right child and then destroy the node.

    if T /= null then
       Destroy_Deep_Tree (T.Left_Child);
       Destroy_Deep_Tree (T.Right_Child);
       Dispose_Label (T.Label);
       Dispose_Value (T.Value);
       Destroy_Tree (T);
    end if;
end;

------------------------------------------------------------------------------

procedure Destroy_Tree ( T :in out Tree) is


begin
    --| OVERVIEW
    --| This procedure recursively destroys the tree T.
    --|  1.  It destroy the Left_Child of T
    --|  2.  It then destroys the Right_Child of T.
    --|  3.  It then destroy the root T and set T to be null.

    if T /= null then
        Destroy_Tree (T.Left_Child);
        Destroy_Tree (T.Right_Child);
        Free (T);
    end if;
end Destroy_Tree;

------------------------------------------------------------------------------

function Fetch_Value (         --| Get the value of the node with the given
                               --| value.
       T :in     Tree;         --| The tree which contains the node.
       L :in     Label_Type    --| The label of the node.
) return Value_Type is

begin
    if T = null then
        raise Label_Not_Present;
    elsif L < T.Label then
        return Fetch_Value (T.Left_Child, L);
    elsif T.Label < L then
        return Fetch_Value (T.Right_Child, L);
    else
        return T.Value;
    end if;
end Fetch_Value;

--------------------------------------------------------------------------

function Fetch_Value (  --| Return the value stored at the root node
                        --| of the given tree.
         T :in Tree
) return Value_Type is

begin
    if T = null then
       raise Tree_Is_Empty;
    else
       return T.Value;
    end if;
end Fetch_Value;

--------------------------------------------------------------------------

procedure Forward (        --| Advances the iterator to the next node in
                           --| the iteration.
  I :in out Tree_Iter      --| Iterator being advance.
) is
begin
    Node_Order.Forward (I.State);
end Forward;

------------------------------------------------------------------------------

function Get_Tree (         --| Get the tree whose root is labelled L.
       T :in    Tree;       --| Tree which contains the label L.
       L :in    Label_Type  --| The label being searched for.
) return Tree is

begin
    if T = null then
        raise Label_Not_Present;
    elsif L < T.Label then
        return Get_Tree (T.Left_Child, L);
    elsif T.Label < L then
        return Get_Tree (T.Right_Child, L);
    else
       return T;
    end if;
end Get_Tree;

------------------------------------------------------------------------------

procedure Insert_Node (       --| This procedure inserts a node into
                              --| the tree T with label and value V.
      T  :in out Tree;
      L  :in     Label_Type;
      V  :in     Value_Type
) is

begin
    if T = null then
       T := new Node '
            ( Value => V, Label => L, Left_Child => null, Right_Child => null);
    elsif L < T.Label then
       Insert_Node (T.Left_Child, L, V);
    elsif T.Label < L then
       Insert_Node (T.Right_Child, L, V);
    elsif T.Label = L then
       raise Label_Already_Exists_In_Tree;
    end if;
end Insert_Node;

------------------------------------------------------------------------------

function Is_Empty (        --| Returns true if the tree is empty false
                           --| otherwise.
         T :in     Tree
) return boolean is
begin
    return T = null;
end Is_Empty;

------------------------------------------------------------------------------

function Is_Label_In_Tree (            --| Is the given label in the given
                                       --| tree.
         T :in    Tree;                --| The tree being searched.
         L :in    Label_Type           --| The label being searched for.
) return boolean is
begin
    if T = null then
         return false;
    elsif L < T.Label then
         return Is_Label_In_Tree (T.Left_Child, L);
    elsif T.Label < L then
         return Is_Label_In_Tree (T.Right_Child, L);
    else
        return true;
    end if;
end Is_Label_In_Tree;

------------------------------------------------------------------------------

procedure Is_Label_In_Tree (            --| Checks if the given label is
                                        --| in the given tree.
           T       :in     Tree;        --| Tree being searched.
           L       :in     Label_Type;  --| Label being searched for.
           Subtree :   out Tree;        --| Subtree which is contains label.
           Present :   out boolean      --| True if label is in tree, false
                                        --| if not.
) is
    Recursed          :boolean := false;
    Internal_Subtree  :Tree;    -- This variable is needed because
                                -- in Internal_Is_Label subtree is an in out
                                -- parameter.

begin
     --| Sets the variable Present to true if the given label is in the given
     --| tree. Also sets the variable Subtree to
     --| the root of the subtree which contains the label.  If L isn't in the
     --| tree then Subtree is the root of the tree where label should be
     --| inserted.  This internal routine is called so that if L isn't in T
     --| then Subtree will be the root of the tree where L should be inserted.
     --| In order to do this we need the extra variable Recursed.

    Internal_Is_Label_In_Tree (T, L, Internal_Subtree, Present, Recursed);
    Subtree := Internal_Subtree;
end Is_Label_In_Tree;

----------------------------------------------------------------------------

function Iterator_Label (  --| Returns the label of the node corresponding
                           --| to the iterator.
  I :in      Tree_Iter     --| Iterator.
) return Label_Type is
    T :Tree;
begin
    T := Node_Order.CellValue (I.State);
    return T.Label;
end Iterator_Label;

-----------------------------------------------------------------------------

function Iterator_Value (  --| Returns the value of the node corresponding
                           --| to the iterator.
  I :in      Tree_Iter     --| Iterator.
) return Value_Type is
    T :Tree;
begin
    T := Node_Order.CellValue (I.State);
    return T.Value;
end;

-------------------------------------------------------------------------------

function Make_Tree (          --| This creates a tree given a label and a
                              --| value.
       L :in     Label_Type;  --| The label.
       V :in     Value_Type   --| The value.
) return Tree is

begin
     return  new Node ' (
                   Value => V,
                   Label => L,
                   Left_Child => null,
                   Right_Child => null
                        );
end;

-------------------------------------------------------------------------------

function Make_Tree_Iter_In  (  --| This sets up an inoder iteration of the
                               --| nodes of the tree.
        T :in     Tree         --| Tree being iterated over
) return Tree_Iter is

--| This sets up the iterator for a tree T.
--| The NodeList keeps track of the order of the nodes of T.  The Node_List
--| is computed by first invoking In_Generate of the Left_Child then append
--| the root node to Node_List and then append the result of In_Generate
--| to Node_List.  Since the tree is ordered such that
--|
--|    Left_Child < root    root < Right_Child
--|
--| Node_Order returns the nodes in ascending order.
--|
--| Thus Node_List keeps the list alive for the duration of the iteration
--| operation.  The variable State is the a pointer into the Node_List
--| which is the current place of the iteration.

    I :Tree_Iter;
begin
    I.Node_List := Node_Order.Create;
    if T /= null then
        Node_Order.Attach (I.Node_List, In_Order_Generate (T));
    end if;
    I.State := Node_Order.MakeListIter (I.Node_List);
    return I;
end Make_Tree_Iter_In;

------------------------------------------------------------------------------

function Make_Tree_Iter_Post (  --| This sets up a postorder iteration of the
                                --| nodes of the tree.
        T :in     Tree          --| Tree being iterated over
) return Tree_Iter is

--| A postorder iteration of the tree ( + a b)  where the root is + and
--| the left child is a and the right child is b will return the nodes
--| in the order a b +.
--| Node_List is a post_ordered list of the nodes of the tree generated
--| by Post_Order Generate. Thus Node_List keeps the list alive for the
--| duration of the iteration operation.  The variable State is the a pointer
--| into the Node_List which is the current place of the iteration.

    I :Tree_Iter;
begin
    I.Node_List := Node_Order.Create;
    if T /= null then
        Node_Order.Attach (I.Node_List, Post_Order_Generate (T));
    end if;
    I.State := Node_Order.MakeListIter (I.Node_List);
    return I;
end Make_Tree_Iter_Post;

-----------------------------------------------------------------------------

function Make_Tree_Iter_Pre (   --| This sets up an iteration of the nodes
                                --| of the tree in preorder.  Then nodes
                                --| of the tree are returned in ascending
                                --| order.
        T :in     Tree          --| Tree being iterated over
) return Tree_Iter is


--| A preorder iteration of the tree ( + a b)  where the root is + and
--| the left child is a and the right child is b will return the nodes
--| in the order + a b .
--| Node_List is a pre_ordered list of the nodes of the tree generated
--| by Pre_Order_Generate. Thus Node_List keeps the list alive for the
--| duration of the iteration operation.  The variable State is the a pointer
--| into the Node_List which is the current place of the iteration.

    I :Tree_Iter;
begin
    I.Node_List := Node_Order.Create;
    if T /= null then
        Node_Order.Attach (I.Node_List, Pre_Order_Generate (T));
    end if;
    I.State := Node_Order.MakeListIter (I.Node_List);
    return I;
end Make_Tree_Iter_Pre;

------------------------------------------------------------------------------

function More (
     I :in Tree_Iter
) return boolean is

begin
    return Node_Order.More (I.State);
end More;

------------------------------------------------------------------------------

procedure Next (
          I     :in out Tree_Iter;
          V     :   out Value_Type
) is


    T :Tree;
begin
    --| OVERVIEW
    --| Next returns the information at the current position in the iterator
    --| and increments the iterator.  This is accomplished by using the iterater
    --| associated with the Node_Order list.  This returns a pointer into the Tree
    --| and then the information found at this node in T is returned.
    Node_Order.Next (I.State, T);
    V := T.Value ;
exception
    when Node_Order.NoMore =>
      raise No_More;
    when others =>
      raise;
end Next;

-----------------------------------------------------------------------------

procedure Next (
          I :in out Tree_Iter;
          V :   out Value_Type;
          L :   out Label_Type
) is

    T :Tree;
begin
    --| OVERVIEW
    --| Next returns the information at the current position in the iterator
    --| and increments the iterator.  This is accomplished by using the
    --| iterater associated with the Node_Order list.  This returns a
    --| pointer into the Tree and then the information found at this node in
    --| T is returned.

    Node_Order.Next (I.State, T);
    V := T.Value ;
    L := T.Label;

exception
    when Node_Order.NoMore =>
      raise No_More;
    when others =>
      raise;
end Next;

-----------------------------------------------------------------------------

procedure Store_Value (
        T :in out Tree;          --| Tree value is being stored in.
        L :in     Label_Type;    --| The label of the node where the
                                 --| information is being stored.
        V :in     Value_Type     --| The value being stored.
) is

begin
    if T = null then
        raise Label_Not_Present;
    elsif L < T.Label then
        Store_Value (T.Left_Child, L, V);
    elsif T.Label < L then
        Store_Value (T.Right_Child, L, V);
    else
        T.Value := V;
    end if;
end Store_Value;

-------------------------------------------------------------------------------

procedure Store_Value (          --| This stores the value V in the root
                                 --| node of the tree T.
        T :in out Tree;          --| Tree value being stored in the tree.
        V :in     Value_Type     --| The value being stored.
) is
begin
    if T /= null then
        T.Value := V;
    else
        raise Label_Not_Present;
    end if;
end Store_Value;

-----------------------------------------------------------------------------
end Labeled_Trees;
--::::::::::
--set.bdy
--::::::::::
package body set_pkg is

--| Overview:
--| See the package spec, private part, for the representation invariants
--| and abstraction function for sets.  These define the implementation
--| scheme.


  -- Constructors:

    function create
        return set is
    begin
        return set(list'(create));
    end create;

    procedure insert(s: in out set;
                     e: in     elem_type) is
    begin
    s := set(attach(e, list(s)));
    end insert;


    procedure delete(s: in out set;
                     e: in     elem_type) is
    begin
    DeleteItems(list(s), e);
    exception
        when ItemNotPresent =>
            null;
    end delete;

    function intersect(s1, s2: set)
    return set is
    intersect_list: list := create;
    iter: ListIter;
    e: elem_type;
    begin
    iter := MakeListIter(list(s1));
    while more(iter) loop
        next(iter, e);
        if IsInList(list(s2), e) then
        intersect_list := attach(intersect_list, e);
        end if;
    end loop;
    return set(intersect_list);
    end intersect;

    function union(s1, s2: set)
    return set is
    union_list: list;
    begin
    return set(attach(copy(list(s1)), copy(list(s2))));
    end union;

    function copy(s: set)
    return set is
    begin
    return set(copy(list(s)));
    end copy;


  -- Query Operations:

    function equal(s1, s2: set)
        return boolean is
        iter: members_iter;
        e: elem_type;
    begin
        -- s2 contains s1?
        iter := make_members_iter(s1);
        while more (iter) loop
            next(iter, e);
            if not is_member(s2, e) then return false; end if;
        end loop;

        -- s1 contains s2?
        iter := make_members_iter(s2);
        while more (iter) loop
            next(iter, e);
            if not is_member(s1, e) then return false; end if;
        end loop;

        -- s2 contains s1 and s1 contains s2 => equal(s1 = s2)
        return true;
    end equal;

    function is_empty(s: set)
        return boolean is
    begin
    return IsEmpty(list(s));
    end is_empty;

    function is_member(s: set;
                       e: elem_type)
        return boolean is
    begin
        return IsInList(list(s), e);
    end is_member;

    function size(s: set)
        return natural is
    l: list := copy(list(s));
    count: natural := 0;
    begin
    while not IsEmpty(l) loop
        count := count + 1;
        DeleteItems(l, FirstValue(l));
    end loop;
    return count;
    end size;


  -- Iterators:

    function make_members_iter(s: set)
        return members_iter is
    begin
        return members_iter(copy(list(s)));
    end make_members_iter;

    function more(iter: members_iter)
        return boolean is
    begin
    return not IsEmpty(list(iter));
    end more;

    procedure next(iter: in out members_iter;
                   e:    out    elem_type) is
        e2: elem_type;
    begin
        e := FirstValue(list(iter));
        DeleteItems(list(iter), FirstValue(list(iter)));
    exception
        when EmptyList =>
        raise no_more;
    end next;


-- Heap Management:

    procedure destroy(s: in out set) is
    begin
    destroy(list(s));
    end destroy;

end set_pkg;
--::::::::::
--stack.bdy
--::::::::::
-- $Source: /nosc/work/abstractions/stack/RCS/stack.bdy,v $
-- $Revision: 1.3 $ -- $Date: 85/02/01 10:19:36 $ -- $Author: ron $

-- $Source: /nosc/work/abstractions/stack/RCS/stack.bdy,v $
-- $Revision: 1.3 $ -- $Date: 85/02/01 10:19:36 $ -- $Author: ron $

with unchecked_deallocation;

package body stack_pkg is

--| Overview:
--| Implementation scheme is totally described by the statements of the
--| representation invariants and abstraction function that appears in
--| the package specification.  The implementation is so trivial that
--| further documentation is unnecessary.

    use elem_list_pkg;


  -- Constructors:

    function create
        return stack is
    begin
    return new stack_rec'(size => 0, elts => create);
    end create;

    procedure push(s: in out stack;
                   e: in     elem_type) is
    begin
        s.size := s.size + 1;
        s.elts := attach(e, s.elts);
    exception
        when constraint_error =>
            raise uninitialized_stack;
    end push;

    procedure pop(s: in out stack) is
    begin
        DeleteHead(s.elts);
        s.size := s.size - 1;
    exception
        when EmptyList =>
            raise empty_stack;
    when constraint_error =>
        raise uninitialized_stack;
    end pop;

    procedure pop(s: in out stack;
                  e: out    elem_type) is
    begin
        e := FirstValue(s.elts);
        DeleteHead(s.elts);
        s.size := s.size - 1;
    exception
        when EmptyList =>
            raise empty_stack;
    when constraint_error =>
        raise uninitialized_stack;
    end pop;

    function copy(s: stack)
        return stack is
    begin
    if s = null then raise uninitialized_stack; end if;

    return new stack_rec'(size => s.size,
                  elts => copy(s.elts));
    end;


  -- Queries:

    function top(s: stack)
        return elem_type is
    begin
        return FirstValue(s.elts);
    exception
        when EmptyList =>
        raise empty_stack;
    when constraint_error =>
        raise uninitialized_stack;
    end top;

    function size(s: stack)
        return natural is
    begin
        return s.size;
    exception
        when constraint_error =>
        raise uninitialized_stack;
    end size;

    function is_empty(s: stack)
        return boolean is
    begin
        return s.size = 0;
    exception
        when constraint_error =>
        raise uninitialized_stack;
    end is_empty;


  -- Heap Management:

    procedure destroy(s: in out stack) is
        procedure free_stack is
        new unchecked_deallocation(stack_rec, stack);
    begin
    destroy(s.elts);
    free_stack(s);
    exception
        when constraint_error =>    -- stack is null
            return;
    end destroy;

end stack_pkg;
--::::::::::
--clp.bdy
--::::::::::
package FILE_LISTER is

   --------------------------------------------------------------------------
   --|BEGIN PROLOGUE
   --| DESCRIPTION            : FILE_LISTER is an abstract state machine which
   --|                        : manipulates a linked list of file names.
   --|                        : Through the ADD_FILE_NAME procedure, the
   --|                        : programmer can add one particular file name
   --|                        : to this list or a group of file names
   --|                        : specified by an include file (which is a file
   --|                        : that contains names of desired files and
   --|                        : other include files).
   --|                        :
   --| REQUIREMENTS SUPPORTED : Object-Oriented Design of an Include File
   --|                        : Processor
   --|                        :
   --| LIMITATIONS            : None
   --|                        :
   --| AUTHOR(S)              : Richard Conn (RC)
   --|                        :
   --| CHANGE LOG             : 02/24/88  RC  Initial Design with PDL
   --|                        : 02/24/88  RC  Code and Test
   --|                        :
   --| REMARKS                : INCLUDE_FILE_PREFIX is brought out
   --|                        : in the front of the package FILE_LISTER
   --|                        : in order to ease portability to systems
   --|                        : other than the original target.
   --|                        :
   --| PORTABILITY ISSUES     : Include file names are prefixed with the
   --|                        : character '@'; this is defined by the constant
   --|                        : INCLUDE_FILE_PREFIX.
   --|END PROLOGUE
   --------------------------------------------------------------------------

   INCLUDE_FILE_PREFIX : constant CHARACTER := '@';
   -- The INCLUDE_FILE_PREFIX is a character which preceeds the
   -- string passed to ADD_FILE_NAME when the characters following
   -- the INCLUDE_FILE_PREFIX comprise the name of an include file

   procedure ADD_FILE_NAME (FILE_NAME : in STRING);
   -- Add the indicated file or include file list to the end of
   -- the file list

   function GET_FILE_NAME return STRING;
   -- Return the next file name from the file list

   function IS_END return BOOLEAN;
   -- Indicate if the end of the file list has been reached

   procedure RESET;
   -- Reset the file list so the next file name is the first file
   -- in the list

   END_OF_FILE_LIST               : exception;
   FILE_LIST_NOT_FOUND            : exception;
   LINKED_LIST_ALLOCATION_PROBLEM : exception;
   UNEXPECTED_ERROR               : exception;

end FILE_LISTER;

with TEXT_IO;
package body FILE_LISTER is

   package LINKED_LIST is

      type FILE_NAME (FILE_NAME_LENGTH : NATURAL);
      type FILE_NAME_POINTER is access FILE_NAME;
      type FILE_NAME (FILE_NAME_LENGTH : NATURAL) is
         record
            NAME : STRING (1 .. FILE_NAME_LENGTH);
            NEXT : FILE_NAME_POINTER;
         end record;

      FIRST_FILE   : FILE_NAME_POINTER := null;
      CURRENT_FILE : FILE_NAME_POINTER := null;
      LAST_FILE    : FILE_NAME_POINTER := null;

   end LINKED_LIST;

   function "=" (LEFT, RIGHT : in LINKED_LIST.FILE_NAME_POINTER) return BOOLEAN
       renames LINKED_LIST."=";
   -- The function provides a visible "=" operator for FILE_NAME_POINTER
   -- objects, eliminating the need to employ a USE clause

   procedure ADD_FILE_NAME (FILE_NAME : in STRING) is

      --============================= PDL ==================================
      --|ABSTRACT:
      --|    ADD_FILE_NAME adds the named file to the file list, building
      --|    onto a linked-list.  If FILE_NAME is an include file,
      --|    all files named by this include file and the include files
      --|    it references are added to the list.
      --|
      --|DESIGN DESCRIPTION:
      --|    If the first character is not the INCLUDE_FILE_PREFIX,
      --|      add the file name to the list
      --|    Else
      --|        Open FILE_NAME; if exception, raise FILE_LIST_NOT_FOUND
      --|        Loop until end of file of FILE_NAME:
      --|            Get next line from include file
      --|            Case next line
      --|                When blank or comment, do nothing
      --|                When include file name, Call ADD_FILE_NAME (recurse)
      --|                When file name, add file name to linked list
      --|            End case
      --|        End loop
      --|    End if
      --|
      --====================================================================

      FD : TEXT_IO.FILE_TYPE;
      type INLINE is
         record
            CONTENT : STRING (1 .. 400);
            LAST    : NATURAL;
         end record;
      FILE : INLINE;

      procedure ADD_NAME_TO_LIST (FILE_NAME : in STRING) is
         TEMP : LINKED_LIST.FILE_NAME_POINTER;
      begin
         if LINKED_LIST.FIRST_FILE = null then
            begin
               LINKED_LIST.FIRST_FILE :=
                  new LINKED_LIST.FILE_NAME (FILE_NAME'LENGTH);
            exception
               when others     =>
                  raise LINKED_LIST_ALLOCATION_PROBLEM;
            end;
            LINKED_LIST.FIRST_FILE.NAME (1 .. FILE_NAME'LENGTH) := FILE_NAME;
            LINKED_LIST.LAST_FILE := LINKED_LIST.FIRST_FILE;
            LINKED_LIST.CURRENT_FILE := LINKED_LIST.FIRST_FILE;
         else
            begin
               TEMP := new LINKED_LIST.FILE_NAME (FILE_NAME'LENGTH);
            exception
               when others     =>
                  raise LINKED_LIST_ALLOCATION_PROBLEM;
            end;
            LINKED_LIST.LAST_FILE.NEXT        := TEMP;
            TEMP.NAME (1 .. FILE_NAME'LENGTH) := FILE_NAME;
            LINKED_LIST.LAST_FILE             := TEMP;
         end if;
      end ADD_NAME_TO_LIST;

   begin
      if FILE_NAME (FILE_NAME'FIRST) /= INCLUDE_FILE_PREFIX then
         ADD_NAME_TO_LIST (FILE_NAME);
      else
         begin
            TEXT_IO.OPEN (FD, TEXT_IO.IN_FILE,
                          FILE_NAME (FILE_NAME'FIRST + 1 .. FILE_NAME'LAST));
         exception
            when others   =>
               raise FILE_LIST_NOT_FOUND;
         end;

         -- Loop through file
         while not TEXT_IO.END_OF_FILE (FD) loop
            TEXT_IO.GET_LINE (FD, FILE.CONTENT, FILE.LAST);
            if FILE.LAST > 0 then
               if FILE.CONTENT (1) /= '-' then
                  if FILE.CONTENT (1) = INCLUDE_FILE_PREFIX then
                     ADD_FILE_NAME (FILE.CONTENT (1 .. FILE.LAST));
                  else
                     ADD_NAME_TO_LIST (FILE.CONTENT (1 .. FILE.LAST));
                  end if;
               end if;
            end if;
         end loop;

         TEXT_IO.CLOSE (FD);

      end if;

   exception
      when FILE_LIST_NOT_FOUND | LINKED_LIST_ALLOCATION_PROBLEM   =>
         raise ;
      when others    =>
         raise UNEXPECTED_ERROR;
   end ADD_FILE_NAME;

   function GET_FILE_NAME return STRING is

      --============================= PDL ==================================
      --|ABSTRACT:
      --|    GET_FILE_NAME returns the next file name from the include
      --|    file.
      --|
      --|DESIGN DESCRIPTION:
      --|    Check to see if LINKED_LIST.CURRENT_FILE is null and raise
      --|      END_OF_FILE_LIST if so
      --|    Set TEMP to point to LINKED_LIST.CURRENT_FILE
      --|    If LINKED_LIST.CURRENT_FILE = LINKED_LIST.LAST_FILE then
      --|        Set LINKED_LIST.LAST_FILE to null
      --|    Else
      --|        Set LINKED_LIST.CURRENT_FILE to LINKED_LIST.CURRENT_FILE.NEXT
      --|    End if
      --|    Return TEMP.NAME
      --====================================================================

      TEMP : LINKED_LIST.FILE_NAME_POINTER;

   begin
      if IS_END then
         raise END_OF_FILE_LIST;
      end if;
      TEMP := LINKED_LIST.CURRENT_FILE;
      if LINKED_LIST.CURRENT_FILE = LINKED_LIST.LAST_FILE then
         LINKED_LIST.CURRENT_FILE := null;
      else
         LINKED_LIST.CURRENT_FILE := LINKED_LIST.CURRENT_FILE.NEXT;
      end if;
      return TEMP.NAME;
   exception
      when END_OF_FILE_LIST    =>
         raise ;
      when others    =>
         raise UNEXPECTED_ERROR;
   end GET_FILE_NAME;

   function IS_END return BOOLEAN is

      --============================= PDL ==================================
      --|ABSTRACT:
      --|   END_OF_FILE indicates when the end of the include file
      --|   (actually, linked list) is encountered.
      --|
      --|DESIGN DESCRIPTION:
      --|   Return TRUE if LINKED_LIST.CURRENT_FILE is null; FALSE otherwise
      --====================================================================

   begin
      return LINKED_LIST.CURRENT_FILE = null;
   end IS_END;

   procedure RESET is

      --============================= PDL ==================================
      --|ABSTRACT:
      --|   RESET resets the FILE_LISTER package for reprocessing
      --|   the current file list.
      --|
      --|DESIGN DESCRIPTION:
      --|   Set LINKED_LIST.CURRENT_FILE to null
      --====================================================================

   begin
      LINKED_LIST.CURRENT_FILE := LINKED_LIST.FIRST_FILE;
   end RESET;

end FILE_LISTER;
-- **********************************************
-- *                                            *
-- * COMMAND_LINE_PROCESSOR                     * BODY
-- *                                            *
-- **********************************************
with CLI;          -- from CLI2.SRC
with FILE_LISTER;  -- from FLISTER.SRC
package body COMMAND_LINE_PROCESSOR is

    NUMBER_OF_FILE_NAME_TOKENS : NATURAL;
    INIT_DONE : BOOLEAN := FALSE;
    OUTPUT_FILE_EXISTS : BOOLEAN := FALSE;

    -- ..............................................
    -- .                                            .
    -- . INITIALIZE                                 . BODY
    -- .                                            .
    -- ..............................................
    procedure INITIALIZE (PROGRAM_NAME : in STRING;
                          COMMAND_KIND : in COMMAND_LINE_LAYOUT
                                         := ONE_OUTPUT_FILE) is
    begin
        if COMMAND_KIND = ONE_OUTPUT_FILE then
            CLI.INITIALIZE(PROGRAM_NAME,
                       "Enter input file names and output file name: ");
            NUMBER_OF_FILE_NAME_TOKENS := CLI.ARGC - 1;
            for I in 1 .. NUMBER_OF_FILE_NAME_TOKENS - 1 loop
                FILE_LISTER.ADD_FILE_NAME(CLI.ARGV(I));
            end loop;
            OUTPUT_FILE_EXISTS := TRUE;
        else
            CLI.INITIALIZE(PROGRAM_NAME,
                       "Enter input file names: ");
            NUMBER_OF_FILE_NAME_TOKENS := CLI.ARGC - 1;
            for I in 1 .. NUMBER_OF_FILE_NAME_TOKENS loop
                FILE_LISTER.ADD_FILE_NAME(CLI.ARGV(I));
            end loop;
            OUTPUT_FILE_EXISTS := FALSE;
        end if;
        INIT_DONE := TRUE;
    exception
        when FILE_LISTER.LINKED_LIST_ALLOCATION_PROBLEM =>
                       raise ALLOCATION_PROBLEM;
        when others => raise UNEXPECTED_ERROR;
    end INITIALIZE;

    -- ..............................................
    -- .                                            .
    -- . RESET                                      . BODY
    -- .                                            .
    -- ..............................................
    procedure RESET is
    begin
        if not INIT_DONE then
            raise INIT_ERROR;
        else
            FILE_LISTER.RESET;
        end if;
    exception
        when INIT_ERROR => raise;
        when others     => raise UNEXPECTED_ERROR;
    end RESET;

    -- ..............................................
    -- .                                            .
    -- . IS_END                                     . BODY
    -- .                                            .
    -- ..............................................
    function IS_END return BOOLEAN is
    begin
        if not INIT_DONE then
            raise INIT_ERROR;
        else
            return FILE_LISTER.IS_END;
        end if;
    exception
        when INIT_ERROR => raise;
        when others     => raise UNEXPECTED_ERROR;
    end IS_END;

    -- ..............................................
    -- .                                            .
    -- . FILE_NAME                                  . BODY
    -- .                                            .
    -- ..............................................
    function FILE_NAME return STRING is
    begin
        if not INIT_DONE then
            raise INIT_ERROR;
        else
            return FILE_LISTER.GET_FILE_NAME;
        end if;
    exception
        when INIT_ERROR => raise;
        when FILE_LISTER.END_OF_FILE_LIST =>
                           raise END_OF_FILE_LIST;
        when others     => raise UNEXPECTED_ERROR;
    end FILE_NAME;

    -- ..............................................
    -- .                                            .
    -- . OUTPUT_FILE_NAME                           . BODY
    -- .                                            .
    -- ..............................................
    function OUTPUT_FILE_NAME return STRING is
    begin
        if not INIT_DONE then
            raise INIT_ERROR;
        else
            if OUTPUT_FILE_EXISTS then
                return CLI.ARGV(NUMBER_OF_FILE_NAME_TOKENS);
            else
                return "";
            end if;
        end if;
    exception
        when INIT_ERROR => raise;
        when others     => raise UNEXPECTED_ERROR;
    end OUTPUT_FILE_NAME;

    -- ..............................................
    -- .                                            .
    -- . FILE_NAME_COUNT                            . BODY
    -- .                                            .
    -- ..............................................
    function FILE_NAME_COUNT return NATURAL is
    begin
        if not INIT_DONE then
            raise INIT_ERROR;
        else
            return NUMBER_OF_FILE_NAME_TOKENS;
        end if;
    exception
        when INIT_ERROR => raise;
        when others     => raise UNEXPECTED_ERROR;
    end FILE_NAME_COUNT;

end COMMAND_LINE_PROCESSOR;
--::::::::::
--lbintree.bdy
--::::::::::
package body labeled_binary_trees_pkg is
--| Efficient implementation of labeled binary trees.

--| OVERVIEW

--| Implemented using Binary_Trees_Pkg.

----------------------------------------------------------------------------
                -- Implementation --
----------------------------------------------------------------------------
-- For the pseudo-private part

function LV_Differ(P, Q: Label_Value_Pair) return integer is
begin
    return Difference(P.Label, Q.Label);

end LV_Differ;

----------------------------------------------------------------------------

Procedure Insert(    --| Insert a label/value into a tree.
    L: Label_Type;    --| Label to be associated with a value
    V: Value_Type;    --| Value to be inserted
    T: Tree        --| Tree to contain the new value
    ) is

begin
    LVT.Insert(Label_Value_Pair'(L, V), T);

end Insert;

----------------------------------------------------------------------------

Procedure Insert_if_not_Found(
--| Insert a value into a tree, provided a duplicate value is not already there
    L: Label_Type;    --| Label to look for
    V: Value_Type;    --| Value to be inserted
    T: Tree;        --| Tree to contain the new value
    Found: out boolean;
    Duplicate: out Value_Type
    ) --| Raises: Invalid_Tree.
is
    was_Found: boolean;
    Match: Label_Value_Pair;

begin
    LVT.Insert_If_Not_Found(Label_Value_Pair'(L, V), T, was_Found, Match);
    Found := was_Found;
    if was_Found then
    Duplicate := Match.Value;
    end if;

end Insert_if_Not_Found;

----------------------------------------------------------------------------

procedure Replace_if_Found(
--| Replace a value if label exists, otherwise insert it.
    L: Label_Type;    --| Label to look for
    V: Value_Type;    --| Value to be inserted
    T: Tree;        --| Tree to contain the new value
    Found: out boolean;    --| Becomes True iff L already in tree
    Old_Value: out Value_Type    --| the duplicate value, if there is one
    ) --| Raises: Invalid_Tree.
is
    was_Found: boolean;
    Match: Label_Value_Pair;

begin
    LVT.Replace_if_Found(Label_Value_Pair'(L, V), T, was_Found, Match);
    Found := was_Found;
    if was_Found then
    Old_Value := Match.Value;
    end if;

end Replace_if_Found;

----------------------------------------------------------------------------

procedure Destroy_Deep(    --| Free all space allocated to a tree.
    T: in out Tree    --| The tree to be reclaimed.
    ) is

    procedure Destroy_Pair(P: in out Label_Value_Pair) is
    begin
    free_Value(P.Value);
    free_Label(P.Label);

    end Destroy_Pair;

    procedure LV_Destroy_Deep is new LVT.Destroy_Deep(Destroy_Pair);

begin
    LV_Destroy_Deep(T);

end Destroy_Deep;

----------------------------------------------------------------------------

function Balanced_Tree(
    Count: natural
    ) return Tree
is
    function Next return Label_Value_Pair is
    L: Label_Type;
    V: Value_Type;
    begin
    Next_Pair(L, V);    -- this is provided with instantiation
    return Label_Value_Pair'(L, V);

    end Next;

    function LV_Balanced_Tree is new LVT.Balanced_Tree(Next);

begin
    return LV_Balanced_Tree(Count);

end Balanced_Tree;

----------------------------------------------------------------------------

function Copy_Tree(
    T: Tree
    ) return Tree
is
    function Copy_Pair(P: Label_Value_Pair) return Label_Value_Pair is
    begin
    return Label_Value_Pair'(copy_Label(P.Label), copy_Value(P.Value));

    end Copy_Pair;

    function LV_Copy_Tree is new LVT.Copy_Tree(Copy_Pair);

begin
    return LV_Copy_Tree(T);

end Copy_Tree;

----------------------------------------------------------------------------

Function Find(        --| Search a tree for a value.
    L: Label_Type;    --| Label to be located
    T: Tree        --| Tree to be searched
    ) return Value_Type --| Raises: Not_Found, Invalid_Tree.
is
    P: Label_Value_Pair;

begin
    P.Label := L;
    P := LVT.Find(P, T);
    return P.Value;

end Find;


Procedure Find(            --| Search a tree for a value.
    L: Label_Type;        --| Label to be located
    T: Tree;            --| Tree to be searched
    Found: out Boolean;        --| TRUE iff a match was found
    Match: out Value_Type    --| Matching value found in the tree
    ) --| Raises: Invalid_Tree;

is
    P: Label_Value_Pair;
    was_Found: boolean;

begin
    P.Label := L;
    LVT.Find(P, T, was_Found, P);
    Found := was_Found;
    if was_Found then
      Match := P.Value;
    end if;

end Find;

----------------------------------------------------------------------------

function is_Found(    --| Check a tree for a value.
    L: Label_Type;    --| Label to be located
    T: Tree        --| Tree to be searched
    ) return Boolean    --| Raises: Invalid_Tree;
is
    P: Label_Value_Pair;
    Found: Boolean;

begin
    P.Label := L;
    LVT.Find(P, T, Found, P);
    return Found;

end is_Found;


--| Effects: Return TRUE iff L is found in T.

----------------------------------------------------------------------------

procedure Visit(
    T: Tree;
    Order: Scan_Kind
    )
is
    procedure Process_Pair(P: Label_Value_Pair) is
    begin
    Process(P.Label, P.Value);

    end Process_Pair;

    procedure LV_Visit is new LVT.Visit(Process_Pair);

begin
    LV_Visit(T, Order);

end Visit;


--| Effects: Invoke Process(V) for each value V in T.  The nodes are visited
--| in the order specified by Order.  Although more limited than using
--| an iterator, this function is also much faster.

----------------------------------------------------------------------------

procedure Next(        --| Scan the next value in I
    I: in out Iterator;    --| an active iterator
    L: out Label_Type;    --| Next label scanned
    V: out Value_Type    --| Next value scanned
    )
is
    P: Label_Value_Pair;

begin
    LVT.Next(I, P);
    L := P.Label;
    V := P.Value;

end Next;

----------------------------------------------------------------------------


end labeled_binary_trees_pkg;
--::::::::::
--ordset.bdy
--::::::::::
package body OrderedSets is
-------------------------------------------------------------------------------
--                Local Subprograms
-------------------------------------------------------------------------------

-------------------------------------------------------------------------------

function "<" (     --| Implements "<" for the type member.
         X :in   Member;
         Y :in   Member
) return boolean is

begin
     return X.Info < Y.Info;
end;

-------------------------------------------------------------------------------


-------------------------------------------------------------------------------
--               Visible Subprograms
-------------------------------------------------------------------------------


-------------------------------------------------------------------------------

function Cardinality (
              S :in Set  --| The set whose size is being computed.
) return natural is

    T        :TreePkg.TreeIter;
    M        :Member;
    count    :natural := 0;
begin
    T := TreePkg.MakeTreeIter (S.SetRep);
    while TreePkg.More (T) loop
        TreePkg.Next (T, M);
        count := count + 1;
    end loop;
    return count;
end Cardinality;

-------------------------------------------------------------------------------

function Create

return Set is
    S :Set;
begin
    S.SetRep := TreePkg.Create;
    return S;
end Create;

------------------------------------------------------------------------------

procedure Destroy (
         S :in out Set
) is

begin
    TreePkg.DestroyTree (S.SetRep);
end Destroy;

-----------------------------------------------------------------------------

function GetCount (
         I :in    SetIter
) return natural is

begin
     return I.Count;
end;

-----------------------------------------------------------------------------
procedure Insert(
          M :in     ItemType;
          S :in out Set
) is
    Subtree       :TreePkg.Tree;
    Exists        :boolean;
    MemberToEnter :Member := ( Info => M, count => 1);
begin
    --| If NewMember doesn't exist in SetRep it is added.  If it does exist
    --| Exists comes back true and then M's count is updated.  Since the
    --| first argument of TreePkg.Insert is in out, after Insert
    --| MemberToEnter has the value stored in the tree.  Thus if we
    --| need to update the count we can simple bump the count in MemberToEnter.

    TreePkg.InsertNode (MemberToEnter, S.SetRep, SubTree, Exists);
    if Exists then
        MemberToEnter.Count := MemberToEnter.Count + 1;
        TreePkg.Deposit (MemberToEnter, SubTree);
    end if;
end Insert;

------------------------------------------------------------------------------

function MakeSetIter (
         S :in Set
)        return SetIter is

    I :SetIter;
begin
    I.Place := TreePkg.MakeTreeIter (S.SetRep);
    I.Count := 0;
    return I;
end;

 ------------------------------------------------------------------------------

function More (
          I :in     SetIter
)         return boolean is

begin
    return TreePkg.More (I.Place);
end;

------------------------------------------------------------------------------

procedure Next (
         I :in out SetIter;
         M :   out ItemType
) is
    TempMember :Member;
begin
    TreePkg.Next (I.Place, TempMember);
    M := TempMember.Info;
    I.Count := TempMember.Count;
end;

------------------------------------------------------------------------------

end OrderedSets;
--::::::::::
--string.bdy
--::::::::::
-- $Source: /nosc/work/abstractions/string/RCS/string.bdy,v $
-- $Revision: 1.3 $ -- $Date: 85/02/01 10:58:51 $ -- $Author: ron $

-- $Source: /nosc/work/abstractions/string/RCS/string.bdy,v $
-- $Revision: 1.3 $ -- $Date: 85/02/01 10:58:51 $ -- $Author: ron $

with unchecked_deallocation;
with lists, stack_pkg;
with case_insensitive_string_comparison;

package body string_pkg is

--| Overview:
--| The implementation for most operations is fairly straightforward.
--| The interesting aspects involve the allocation and deallocation of
--| heap space.  This is done as follows:
--|
--|     1. A stack of accesses to lists of string_type values is set up
--|        so that the top of the stack always refers to a list of values
--|        that were allocated since the last invocation of mark.
--|        The stack is called scopes, referring to the dynamic scopes
--|        defined by the invocations of mark and release.
--|        There is an implicit invocation of mark when the
--|        package body is elaborated; this is implemented with an explicit
--|        invocation in the package initialization code.
--|
--|     2. At each invocation of mark, a pointer to an empty list
--|        is pushed onto the stack.
--|
--|     3. At each invocation of release, all of the values in the
--|        list referred to by the pointer at the top of the stack are
--|        returned to the heap.  Then the list, and the pointer to it,
--|        are returned to the heap.  Finally, the stack is popped.

    package CISC renames case_insensitive_string_comparison;

    package string_list_pkg is new lists(string_type);
    subtype string_list is string_list_pkg.list;

    type string_list_ptr is access string_list;

    package scope_stack_pkg is new stack_pkg(string_list_ptr);
    subtype scope_stack is scope_stack_pkg.stack;

    use string_list_pkg;
    use scope_stack_pkg;

    scopes: scope_stack;     -- See package body overview.

    current_comparison_option: comparison_option := case_sensitive;

    -- Utility functions/procedures:

    function enter(s: in string_type)
        return string_type;

      --| Raises: illegal_alloc
      --| Effects:
      --| Stores s, the address of s.all, in current scope list (top(scopes)),
      --| and returns s.  Useful for functions that create and return new
      --| string_type values.
      --| Raises illegal_alloc if the scopes stack is empty.

    function string_lower(s: in string)
    return string;

      --| Effects:
      --| Return a string with the same bounds and contents as s, with the
      --| exception that all upper case characters are replaced with their
      --| lower case counterparts.

    function string_upper(s: in string)
    return string;

      --| Effects:
      --| Return a string with the same bounds and contents as s, with the
      --| exception that all lower case characters are replaced with their
      --| upper case counterparts.

    function string_equal(s1, s2: in string)
    return boolean;

      --| Effects:
      --| If current_comparison_option = case_sensitive, then return
      --| (s1 = s2); otherwise, return string_lower(s1) = string_lower(s2).

    function string_less(s1, s2: in string)
    return boolean;

      --| Effects:
      --| If current_comparison_option = case_sensitive, then return
      --| (s1 < s2); otherwise, return string_lower(s1) < string_lower(s2).

    function string_less_or_equal(s1, s2: in string)
    return boolean;

      --| Effects:
      --| If current_comparison_option = case_sensitive, then return
      --| (s1 <= s2); otherwise, return string_lower(s1) <= string_lower(s2).

    function match_string(s1, s2: in string; start: in positive := 1)
        return natural;

      --| Raises: no_match
      --| Effects:
      --| Returns the minimum index, i, in s1'range such that
      --| s1(i..i + s2'length - 1) = s2.  Returns 0 if no such index.
      --| Requires:
      --| s1'first = 1.

-- Constructors:

    function create(s: in string)
        return string_type is
        subtype constr_str is string(1..s'length);
        dec_s: constr_str := s;
    begin
          return enter(new constr_str'(dec_s));
    end create;


    function "&"(s1, s2: in string_type)
        return string_type is
    begin
    if is_empty(s1) then return enter(make_persistent(s2)); end if;
    if is_empty(s2) then return enter(make_persistent(s1)); end if;
        return create(s1.all & s2.all);
    end "&";

    function "&"(s1: in string_type; s2: in string)
        return string_type is
    begin
    if s1 = null then return create(s2); end if;
    return create(s1.all & s2);
    end "&";

    function "&"(s1: in string; s2: in string_type)
        return string_type is
    begin
    if s2 = null then return create(s1); end if;
    return create(s1 & s2.all);
    end "&";

    function substr(s: in string_type; i: in positive; len: in natural)
        return string_type is
    begin
        if len = 0 then return null; end if;
        return create(s(i..(i + len - 1)));
    exception
    when constraint_error =>      -- on array fetch or null deref
        raise bounds;
    end substr;

    function splice(s: in string_type; i: in positive; len: in natural)
        return string_type is
    begin
        if len = 0 then return enter(make_persistent(s)); end if;
        if i + len - 1 > length(s) then raise bounds; end if;

        return create(s(1..(i - 1)) & s((i + len)..length(s)));
    end splice;

    function insert(s1, s2: in string_type; i: in positive)
        return string_type is
    begin
        if i > length(s1) + 1 then raise bounds; end if;

    if s1 = null then return create(value(s2)); end if;
    if s2 = null then return create(s1.all); end if;

        return create(s1(1..(i - 1)) & s2.all & s1(i..s1'last));
    end insert;

    function insert(s1: in string_type; s2: in string; i: in positive)
        return string_type is
    begin
        if i > length(s1) + 1 then raise bounds; end if;
    if s1 = null then return create(s2); end if;

        return create(s1(1..(i - 1)) & s2 & s1(i..s1'last));
    end insert;

    function insert(s1: in string; s2: in string_type; i: in positive)
        return string_type is
    begin
    if i not in s1'first..s1'last + 1 then raise bounds; end if;
    if s2 = null then return create(s1); end if;

        return create(s1(s1'first..(i - 1)) & s2.all & s1(i..s1'last));
    end insert;

    function lower(s: in string)
    return string_type is
    begin
    return create(string_lower(s));
    end lower;

    function lower(s: in string_type)
    return string_type is
    begin
    if s = null then return null; end if;
    return create(string_lower(s.all));
    end lower;

    function upper(s: in string)
    return string_type is
    begin
    return create(string_upper(s));
    end upper;

    function upper(s: in string_type)
    return string_type is
    begin
    if s = null then return null; end if;
    return create(string_upper(s.all));
    end upper;


-- Heap Management:

    function make_persistent(s: in string_type)
    return string_type is
        subtype constr_str is string(1..length(s));
    begin
        if s = null or else s.all = "" then return null;
        else return new constr_str'(s.all);
        end if;
    end make_persistent;

    function make_persistent(s: in string)
    return string_type is
        subtype constr_str is string(1..s'length);
        dec_s: constr_str := s;
    begin
    if dec_s = "" then return null;
        else return new constr_str'(dec_s); end if;
    end make_persistent;

    procedure real_flush is new unchecked_deallocation(string,
                                                       string_type);
      --| Effect:
      --| Return space used by argument to heap.  Does nothing if null.
      --| Notes:
      --| This procedure is actually the body for the flush procedure,
      --| but a generic instantiation cannot be used as a body for another
      --| procedure.  You tell me why.

    procedure flush(s: in out string_type) is
    begin
        if s /= null then real_flush(s); end if;
        -- Actually, the if isn't needed; however, DECada compiler chokes
        -- on deallocation of null.
    end flush;

    procedure mark is
    begin
        push(scopes, new string_list'(create));
    end mark;

    procedure release is
        procedure flush_list_ptr is
            new unchecked_deallocation(string_list, string_list_ptr);
        iter: string_list_pkg.ListIter;
        top_list: string_list_ptr;
        s: string_type;
    begin
        pop(scopes, top_list);
        iter := MakeListIter(top_list.all);
        while more(iter) loop
            next(iter, s);
            flush(s);             -- real_flush is bad, DECada bug
--          real_flush(s);
        end loop;
        destroy(top_list.all);
        flush_list_ptr(top_list);
    exception
        when empty_stack =>
            raise illegal_dealloc;
    end release;


-- Queries:

    function is_empty(s: in string_type)
        return boolean is
    begin
        return (s = null) or else (s.all = "");
    end is_empty;

    function length(s: in string_type)
        return natural is
    begin
    if s = null then return 0; end if;
        return(s.all'length);
    end length;

    function value(s: in string_type)
        return string is
        subtype null_range is positive range 1..0;
        subtype null_string is string(null_range);
    begin
    if s = null then return null_string'(""); end if;
        return s.all;
    end value;

    function fetch(s: in string_type; i: in positive)
        return character is
    begin
    if is_empty(s) or else (i not in s'range) then raise bounds; end if;
        return s(i);
    end fetch;

    procedure set_comparison_option(choice: in comparison_option) is
    begin
    current_comparison_option := choice;
    end set_comparison_option;

    function get_comparison_option
    return comparison_option is
    begin
    return current_comparison_option;
    end get_comparison_option;

    function equal(s1, s2: in string_type)
        return boolean is
    begin
        if is_empty(s1) then return is_empty(s2); end if;
        return (s2 /= null) and then string_equal(s1.all, s2.all);
    end equal;

    function equal(s1: in string_type; s2: in string)
        return boolean is
    begin
    if s1 = null then return s2 = ""; end if;
        return string_equal(s1.all, s2);
    end equal;

    function equal(s1: in string; s2: in string_type)
        return boolean is
    begin
    if s2 = null then return s1 = ""; end if;
        return string_equal(s1, s2.all);
    end equal;

    function "<"(s1, s2: in string_type)
        return boolean is
    begin
        if is_empty(s1) then
        return (not is_empty(s2));
    else
        return (s1.all < s2);
    end if;
    end "<";

    function "<"(s1: in string_type; s2: in string)
        return boolean is
    begin
    if s1 = null then return s2 /= ""; end if;
        return string_less(s1.all, s2);
    end "<";

    function "<"(s1: in string; s2: in string_type)
        return boolean is
    begin
    if s2 = null then return false; end if;
        return string_less(s1, s2.all);
    end "<";

    function "<="(s1, s2: in string_type)
        return boolean is
    begin
    if is_empty(s1) then return true; end if;
    return (s1.all <= s2);
    end "<=";

    function "<="(s1: in string_type; s2: in string)
        return boolean is
    begin
    if s1 = null then return true; end if;
        return string_less_or_equal(s1.all, s2);
    end "<=";

    function "<="(s1: in string; s2: in string_type)
        return boolean is
    begin
    if s2 = null then return s1 = ""; end if;
        return string_less_or_equal(s1, s2.all);
    end "<=";

    function match_c(s: in string_type; c: in character; start: in positive := 1)
        return natural is
    begin
    if s = null then return 0; end if;
        for i in start..s.all'last loop
            if s(i) = c then
                return i;
            end if;
        end loop;
        return 0;
    end match_c;

    function match_not_c(s: in string_type; c: in character; start: in positive := 1)
        return natural is
    begin
    if s = null then return 0; end if;
        for i in start..s.all'last loop
        if s(i) /= c then
        return i;
        end if;
        end loop;
    return 0;
    end match_not_c;

    function match_s(s1, s2: in string_type; start: in positive := 1)
        return natural is
    begin
    if (s1 = null) or else (s2 = null) then return 0; end if;
        return match_string(s1.all, s2.all, start);
    end match_s;

    function match_s(s1: in string_type; s2: in string; start: in positive := 1)
        return natural is
    begin
    if s1 = null then return 0; end if;
        return match_string(s1.all, s2, start);
    end match_s;

    function match_any(s, any: in string_type; start: in positive := 1)
        return natural is
    begin
    if any = null then raise any_empty; end if;
        return match_any(s, any.all, start);
    end match_any;

    function match_any(s: in string_type; any: in string; start: in positive := 1)
        return natural is
    begin
        if any = "" then raise any_empty; end if;
        if s = null then return 0; end if;

        for i in start..s.all'last loop
            for j in any'range loop
                if s(i) = any(j) then
                    return i;
                end if;
            end loop;
        end loop;
        return 0;
    end match_any;

    function match_none(s, none: in string_type; start: in positive := 1)
        return natural is
    begin
    if is_empty(s) then return 0; end if;
    if is_empty(none) then return 1; end if;

        return match_none(s, none.all, start);
    end match_none;

    function match_none(s: in string_type; none: in string; start: in positive := 1)
        return natural is
        found: boolean;
    begin
    if is_empty(s) then return 0; end if;

        for i in start..s.all'last loop
            found := true;
            for j in none'range loop
                if s(i) = none(j) then
                    found := false;
                    exit;
                end if;
            end loop;
            if found then return i; end if;
        end loop;
        return 0;
    end match_none;


    -- Utilities:

    function enter(s: in string_type)
        return string_type is
    begin
        top(scopes).all := attach(top(scopes).all, s);
        return s;
    exception
        when empty_stack =>
            raise illegal_alloc;
    end enter;

    function string_lower(s: in string)
    return string is

    begin
    return CISC.downCase(S);

    end string_lower;

    function string_upper(s: in string)
    return string is

    begin
    return CISC.upCase(S);

    end string_upper;

    function string_equal(s1, s2: in string)
    return boolean is
    begin
    if current_comparison_option = case_sensitive then
        return s1 = s2;
    else
        return CISC.equal(S1, S2);
    end if;

    end string_equal;

    function string_less(s1, s2: in string)
    return boolean is
    begin
    if current_comparison_option = case_sensitive then
        return s1 < s2;
    else
        return CISC.less(S1, S2);
    end if;

    end string_less;

    function string_less_or_equal(s1, s2: in string)
    return boolean is
    begin
    if current_comparison_option = case_sensitive then
        return s1 <= s2;
    else
        return CISC.less_or_equal(S1, S2);
    end if;

    end string_less_or_equal;

    function match_string(s1, s2: in string; start: in positive := 1)
        return natural is
        offset: natural;
    begin
        offset := s2'length - 1;
        for i in start..(s1'last - offset) loop
            if s1(i..(i + offset)) = s2 then
                return i;
            end if;
        end loop;
        return 0;
    exception when constraint_error =>    -- on offset := s2'length (= 0)
        return 0;
    end match_string;


begin    -- Initialize the scopes stack with an implicit mark.
    scopes := create;
    mark;
end string_pkg;
--::::::::::
--sscan.bdy
--::::::::::
with String_Pkg;            use String_Pkg;
with Unchecked_Deallocation;

package body String_Scanner is


White_Space   : constant string := " " & ASCII.HT;
Number_1      : constant string := "0123456789";
Number        : constant string := Number_1 & "_";
Quote         : constant string := """";
Ada_Id_1      : constant string := "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz";
Ada_Id        : constant string := Ada_Id_1 & Number;

procedure Free_Scanner is
    new Unchecked_Deallocation(Scan_Record, Scanner);
function Is_Valid(
    T : in Scanner
    ) return boolean is

begin

    return T /= null;

end Is_Valid;

function Make_Scanner(
    S : in String_Type
    ) return Scanner is

    T : Scanner := new Scan_Record;

begin

    T.text := String_Pkg.Make_Persistent(S);
    return T;

end Make_Scanner;

----------------------------------------------------------------

procedure Destroy_Scanner(
    T : in out Scanner
    ) is

begin

    if Is_Valid(T) then
    String_Pkg.Flush(T.text);
    Free_Scanner(T);
    end if;

end Destroy_Scanner;

----------------------------------------------------------------

function More(
    T : in Scanner
    ) return boolean is

begin

    if Is_Valid(T) then
    if T.index > String_Pkg.Length(T.text) then
        return false;
    else
            return true;
    end if;
    else
    return false;
    end if;

end More;

----------------------------------------------------------------

function Get(
    T : in Scanner
    ) return character is

begin

    if not More(T) then
    raise Out_Of_Bounds;
    end if;
    return String_Pkg.Fetch(T.text, T.index);

end Get;

----------------------------------------------------------------

procedure Forward(
    T : in Scanner
    ) is

begin

    if Is_Valid(T) then
    if String_Pkg.Length(T.text) >= T.index then
        T.index := T.index + 1;
    end if;
    end if;

end Forward;

----------------------------------------------------------------

procedure Backward(
    T : in Scanner
    ) is

begin

    if Is_Valid(T) then
    if T.index > 1 then
        T.index := T.index - 1;
    end if;
    end if;

end Backward;

----------------------------------------------------------------

procedure Next(
    T : in     Scanner;
    C :    out character
    ) is

begin

    C := Get(T);
    Forward(T);

end Next;

----------------------------------------------------------------

function Position(
    T : in Scanner
    ) return positive is

begin

    if not More(T) then
    raise Out_Of_Bounds;
    end if;
    return T.index;

end Position;

----------------------------------------------------------------

function Get_String(
    T : in Scanner
    ) return String_Type is

begin

    if Is_Valid(T) then
    return String_Pkg.Make_Persistent(T.text);
    else
    return String_Pkg.Make_Persistent("");
    end if;

end Get_String;

----------------------------------------------------------------

function Get_Remainder(
    T : in Scanner
    ) return String_Type is

    S_Str : String_Type;

begin

    if More(T) then
    String_Pkg.Mark;
    S_Str := String_Pkg.Make_Persistent(
    String_Pkg.Substr(T.text,
              T.index,
              String_Pkg.Length(T.text) - T.index + 1));
    String_Pkg.Release;
    else
    S_Str := String_Pkg.Make_Persistent("");
    end if;
    return S_Str;

end Get_Remainder;

----------------------------------------------------------------

procedure Mark(
    T : in Scanner
    ) is

begin

    if Is_Valid(T) then
    if T.mark /= 0 then
        raise Scanner_Already_Marked;
    else
        T.mark := T.index;
    end if;
    end if;

end Mark;

----------------------------------------------------------------

procedure Restore(
    T : in Scanner
    ) is

begin

    if Is_Valid(T) then
    if T.mark /= 0 then
        T.index := T.mark;
        T.mark  := 0;
    end if;
    end if;

end Restore;

function Is_Any(
    T : in Scanner;
    Q : in string
    ) return boolean is

    N     : natural;

begin

    if not More(T) then
    return false;
    end if;
    String_Pkg.Mark;
    N := String_Pkg.Match_Any(T.text, Q, T.index);
    if N /= T.index then
    N := 0;
    end if;
    String_Pkg.Release;
    return N /= 0;

end Is_Any;

procedure Scan_Any(
    T      : in     Scanner;
    Q      : in     string;
    Found  :    out boolean;
    Result : in out String_Type
    ) is

    S_Str : String_Type;
    N     : natural;

begin

    if Is_Any(T, Q) then
    N := String_Pkg.Match_None(T.text, Q, T.index);
    if N = 0 then
        N := String_Pkg.Length(T.text) + 1;
    end if;
    Result  := Result & String_Pkg.Substr(T.text, T.index, N - T.index);
    T.index := N;
    Found   := true;
    else
    Found := false;
    end if;

end Scan_Any;

function Quoted_String(
    T : in Scanner
    ) return integer is

    Count : integer := 0;
    I     : positive;
    N     : natural;

begin

    if not Is_Valid(T) then
    return Count;
    end if;
    I := T.index;
    while Is_Any(T, """") loop
    T.index := T.index + 1;
    if not More(T) then
        T.index := I;
        return 0;
    end if;
    String_Pkg.Mark;
    N := String_Pkg.Match_Any(T.text, """", T.index);
    String_Pkg.Release;
    if N = 0 then
        T.index := I;
        return 0;
    end if;
    T.index := N + 1;
    end loop;
    Count := T.index - I;
    T.index := I;
    return Count;

end Quoted_String;

function Enclosed_String(
    B : in character;
    E : in character;
    T : in Scanner
    ) return natural is

    Count : natural := 1;
    I     : positive;
    Inx_B : natural;
    Inx_E : natural;
    Depth : natural := 1;

begin

    if not Is_Any(T, B & "") then
    return 0;
    end if;
    I := T.index;
    Forward(T);
    while Depth /= 0 loop
    if not More(T) then
        T.index := I;
        return 0;
    end if;
    String_Pkg.Mark;
    Inx_B   := String_Pkg.Match_Any(T.text, B & "", T.index);
    Inx_E   := String_Pkg.Match_Any(T.text, E & "", T.index);
    String_Pkg.Release;
    if Inx_E = 0 then
        T.index := I;
        return 0;
    end if;
    if Inx_B /= 0 and then Inx_B < Inx_E then
        Depth := Depth + 1;
    else
        Inx_B := Inx_E;
        Depth := Depth - 1;
    end if;
    T.index := Inx_B + 1;
    end loop;
    Count := T.index - I;
    T.index := I;
    return Count;

end Enclosed_String;

function Is_Word(
    T : in Scanner
    ) return boolean is

begin

    if not More(T) then
    return false;
    else
    return not Is_Any(T, White_Space);
    end if;

end Is_Word;

----------------------------------------------------------------

procedure Scan_Word(
    T      : in     Scanner;
    Found  :    out boolean;
    Result :    out String_Type;
    Skip   : in     boolean := false
    ) is

    S_Str : String_Type;
    N     : natural;

begin

    if Skip then
    Skip_Space(T);
    end if;
    if Is_Word(T) then
    String_Pkg.Mark;
    N := String_Pkg.Match_Any(T.text, White_Space, T.index);
    if N = 0 then
        N := String_Pkg.Length(T.text) + 1;
    end if;
    Result  := String_Pkg.Make_Persistent
           (String_Pkg.Substr(T.text, T.index, N - T.index));
    T.index := N;
    Found   := true;
    String_Pkg.Release;
    else
    Found   := false;
    end if;
    return;

end Scan_Word;

function Is_Number(
    T : in Scanner
    ) return boolean is

begin

    return Is_Any(T, Number_1);

end Is_Number;

----------------------------------------------------------------

procedure Scan_Number(
    T      : in     Scanner;
    Found  :    out boolean;
    Result :    out String_Type;
    Skip   : in     boolean := false
    ) is

    C     : character;
    S_Str : String_Type;

begin

    if Skip then
    Skip_Space(T);
    end if;
    if not Is_Number(T) then
    Found := false;
    return;
    end if;
    String_Pkg.Mark;
    while Is_Number(T) loop
    Scan_Any(T, Number_1, Found, S_Str);
    if More(T) then
        C := Get(T);
        if C = '_' then
        Forward(T);
        if Is_Number(T) then
            S_Str := S_Str & "_";
        else
            Backward(T);
        end if;
        end if;
    end if;
    end loop;
    Result := String_Pkg.Make_Persistent(S_Str);
    String_Pkg.Release;

end Scan_Number;

----------------------------------------------------------------

procedure Scan_Number(
    T      : in     Scanner;
    Found  :    out boolean;
    Result :    out integer;
    Skip   : in     boolean := false
    ) is

    F     : boolean;
    S_Str : String_Type;

begin

    Scan_Number(T, F, S_Str, Skip);
    if F then
    Result := integer'value(String_Pkg.Value(S_Str));
    end if;
    Found := F;

end Scan_Number;

function Is_Signed_Number(
    T : in Scanner
    ) return boolean is

    I : positive;
    C : character;
    F : boolean;

begin

    if More(T) then
    I := T.index;
    C := Get(T);
    if C = '+' or C = '-' then
        T.index := T.index + 1;
    end if;
    F := Is_Any(T, Number_1);
    T.index := I;
    return F;
    else
    return false;
    end if;

end Is_Signed_Number;

----------------------------------------------------------------

procedure Scan_Signed_Number(
    T      : in     Scanner;
    Found  :    out boolean;
    Result :    out String_Type;
    Skip   : in     boolean := false
    ) is

    C     : character;
    S_Str : String_Type;

begin

    if Skip then
    Skip_Space(T);
    end if;
    if Is_Signed_Number(T) then
    C := Get(T);
    if C = '+' or C = '-' then
        Forward(T);
    end if;
    Scan_Number(T, Found, S_Str);
    String_Pkg.Mark;
    if C = '+' or C = '-' then
        Result := String_Pkg.Make_Persistent(("" & C) & S_Str);
    else
        Result := String_Pkg.Make_Persistent(S_Str);
    end if;
    String_Pkg.Release;
    String_Pkg.Flush(S_Str);
    else
    Found := false;
    end if;

end Scan_Signed_Number;

----------------------------------------------------------------

procedure Scan_Signed_Number(
    T      : in     Scanner;
    Found  :    out boolean;
    Result :    out integer;
    Skip   : in     boolean := false
    ) is

    F     : boolean;
    S_Str : String_Type;

begin

    Scan_Signed_Number(T, F, S_Str, Skip);
    if F then
    Result := integer'value(String_Pkg.Value(S_Str));
    end if;
    Found := F;

end Scan_Signed_Number;

function Is_Space(
    T : in Scanner
    ) return boolean is

begin

    return Is_Any(T, White_Space);

end Is_Space;

----------------------------------------------------------------

procedure Scan_Space(
    T      : in     Scanner;
    Found  :    out boolean;
    Result :    out String_Type
    ) is

    S_Str : String_Type;

begin

    String_Pkg.Mark;
    Scan_Any(T, White_Space, Found, S_Str);
    Result := String_Pkg.Make_Persistent(S_Str);
    String_Pkg.Release;

end Scan_Space;

----------------------------------------------------------------

procedure Skip_Space(
    T : in Scanner
    ) is

    S_Str : String_Type;
    Found : boolean;

begin

    String_Pkg.Mark;
    Scan_Any(T, White_Space, Found, S_Str);
    String_Pkg.Release;

end Skip_Space;

function Is_Ada_Id(
    T : in Scanner
    ) return boolean is

begin

    return Is_Any(T, Ada_Id_1);

end Is_Ada_Id;

----------------------------------------------------------------

procedure Scan_Ada_Id(
    T      : in     Scanner;
    Found  :    out boolean;
    Result :    out String_Type;
    Skip   : in     boolean := false
    ) is

    C     : character;
    F     : boolean;
    S_Str : String_Type;

begin

    if Skip then
    Skip_Space(T);
    end if;
    if Is_Ada_Id(T) then
    String_Pkg.Mark;
    Next(T, C);
    Scan_Any(T, Ada_Id, F, S_Str);
    Result := String_Pkg.Make_Persistent(("" & C) & S_Str);
    Found := true;
    String_Pkg.Release;
    else
    Found := false;
    end if;

end Scan_Ada_Id;

function Is_Quoted(
    T : in Scanner
    ) return boolean is

begin

    if Quoted_String(T) = 0 then
    return false;
    else
    return true;
    end if;

end Is_Quoted;

----------------------------------------------------------------

procedure Scan_Quoted(
    T      : in     Scanner;
    Found  :    out boolean;
    Result :    out String_Type;
    Skip   : in     boolean := false
    ) is

    Count : integer;

begin

    if Skip then
    Skip_Space(T);
    end if;
    Count := Quoted_String(T);
    if Count /= 0 then
    Count := Count - 2;
    T.index := T.index + 1;
    if Count /= 0 then
        String_Pkg.Mark;
        Result := String_Pkg.Make_Persistent
              (String_Pkg.Substr(T.text, T.index, positive(Count)));
        String_Pkg.Release;
    else
        Result := String_Pkg.Make_Persistent("");
    end if;
    T.index := T.index + Count + 1;
    Found := true;
    else
    Found := false;
    end if;

end Scan_Quoted;

function Is_Enclosed(
    B : in character;
    E : in character;
    T : in Scanner
    ) return boolean is

begin

    if Enclosed_String(B, E, T) = 0 then
    return false;
    else
    return true;
    end if;

end Is_Enclosed;

----------------------------------------------------------------

procedure Scan_Enclosed(
    B      : in     character;
    E      : in     character;
    T      : in     Scanner;
    Found  :    out boolean;
    Result :    out String_Type;
    Skip   : in     boolean := false
    ) is

    Count : natural;

begin

    if Skip then
    Skip_Space(T);
    end if;
    Count := Enclosed_String(B, E, T);
    if Count /= 0 then
    Count := Count - 2;
    T.index := T.index + 1;
    if Count /= 0 then
        String_Pkg.Mark;
        Result := String_Pkg.Make_Persistent(String_Pkg.Substr(T.text, T.index, positive(Count)));
        String_Pkg.Release;
    else
        Result := String_Pkg.Make_Persistent("");
    end if;
    T.index := T.index + Count + 1;
    Found := true;
    else
    Found := false;
    end if;

end Scan_Enclosed;

function Is_Sequence(
    Chars  : in String_Type;
    T      : in Scanner
    ) return boolean is

begin

    return Is_Any(T, String_Pkg.Value(Chars));

end Is_Sequence;

----------------------------------------------------------------

function Is_Sequence(
    Chars  : in string;
    T      : in Scanner
    ) return boolean is

begin

    return Is_Any(T, Chars);

end Is_Sequence;

----------------------------------------------------------------

procedure Scan_Sequence(
    Chars  : in     String_Type;
    T      : in     Scanner;
    Found  :    out boolean;
    Result :    out String_Type;
    Skip   : in     boolean := false
    ) is

    I     : positive;
    Count : integer := 0;

begin

    if Skip then
    Skip_Space(T);
    end if;
    if not Is_Valid(T) then
    Found := false;
    return;
    end if;
    I := T.index;
    while Is_Any(T, Value(Chars)) loop
    Forward(T);
    Count := Count + 1;
    end loop;
    if Count /= 0 then
    String_Pkg.Mark;
    Result := String_Pkg.Make_Persistent
          (String_Pkg.Substr(T.text, I, positive(Count)));
    Found  := true;
    String_Pkg.Release;
    else
    Found := false;
    end if;

end Scan_Sequence;

----------------------------------------------------------------

procedure Scan_Sequence(
    Chars  : in     string;
    T      : in     Scanner;
    Found  :    out boolean;
    Result :    out String_Type;
    Skip   : in     boolean := false
    ) is

begin

    String_Pkg.Mark;
    Scan_Sequence(String_Pkg.Create(Chars), T, Found, Result, Skip);
    String_Pkg.Release;

end Scan_Sequence;

function Is_Not_Sequence(
    Chars  : in String_Type;
    T      : in Scanner
    ) return boolean is

    N : natural;

begin

    if not Is_Valid(T) then
    return false;
    end if;
    String_Pkg.Mark;
    N := String_Pkg.Match_Any(T.text, Chars, T.index);
    if N = T.index then
    N := 0;
    end if;
    String_Pkg.Release;
    return N /= 0;

end Is_Not_Sequence;

----------------------------------------------------------------

function Is_Not_Sequence(
    Chars  : in string;
    T      : in Scanner
    ) return boolean is

begin

    return Is_Not_Sequence(String_Pkg.Create(Chars), T);

end Is_Not_Sequence;

----------------------------------------------------------------

procedure Scan_Not_Sequence(
    Chars  : in     string;
    T      : in     Scanner;
    Found  :    out boolean;
    Result :    out String_Type;
    Skip   : in     boolean := false
    ) is

    N     : natural;

begin

    if Skip then
    Skip_Space(T);
    end if;
    if Is_Not_Sequence(Chars, T) then
    String_Pkg.Mark;
    N := String_Pkg.Match_Any(T.text, Chars, T.index);
    Result := String_Pkg.Make_Persistent
          (String_Pkg.Substr(T.text, T.index, N - T.index));
    T.index := N;
    Found   := true;
    String_Pkg.Release;
    else
    Found := false;
    end if;

end Scan_Not_Sequence;

----------------------------------------------------------------

procedure Scan_Not_Sequence(
    Chars  : in     String_Type;
    T      : in     Scanner;
    Found  :    out boolean;
    Result :    out String_Type;
    Skip   : in     boolean := false
    ) is

begin

    Scan_Not_Sequence(String_Pkg.Value(Chars), T, Found, Result, Skip);

end Scan_Not_Sequence;

function Is_Literal(
    Chars  : in String_Type;
    T      : in Scanner
    ) return boolean is

    N : natural;

begin

    if not Is_Valid(T) then
    return false;
    end if;
    String_Pkg.Mark;
    N := String_Pkg.Match_S(T.text, Chars, T.index);
    if N /= T.index then
    N := 0;
    end if;
    String_Pkg.Release;
    return N /= 0;

end Is_Literal;

----------------------------------------------------------------

function Is_Literal(
    Chars  : in string;
    T      : in Scanner
    ) return boolean is

    Found : boolean;

begin

    String_Pkg.Mark;
    Found := Is_Literal(String_Pkg.Create(Chars), T);
    String_Pkg.Release;
    return Found;

end Is_Literal;

----------------------------------------------------------------

procedure Scan_Literal(
    Chars  : in     String_Type;
    T      : in     Scanner;
    Found  :    out boolean;
    Skip   : in     boolean := false
    ) is

begin

    if Skip then
    Skip_Space(T);
    end if;
    if Is_Literal(Chars, T) then
    T.index := T.index + String_Pkg.Length(Chars);
    Found   := true;
    else
    Found   := false;
    end if;

end Scan_Literal;

----------------------------------------------------------------

procedure Scan_Literal(
    Chars  : in     string;
    T      : in     Scanner;
    Found  :    out boolean;
    Skip   : in     boolean := false
    ) is

begin

    String_Pkg.Mark;
    Scan_Literal(String_Pkg.Create(Chars), T, Found, Skip);
    String_Pkg.Release;

end Scan_Literal;

function Is_Not_Literal(
    Chars : in string;
    T     : in Scanner
    ) return boolean is

    N     : natural;

begin

    if not Is_Valid(T) then
    return false;
    end if;
    String_Pkg.Mark;
    N := String_Pkg.Match_S(T.text, Chars, T.index);
    if N = T.index then
    N := 0;
    end if;
    String_Pkg.Release;
    return N /= 0;

end Is_Not_Literal;

----------------------------------------------------------------

function Is_Not_Literal(
    Chars : in String_Type;
    T     : in Scanner
    ) return boolean is

begin

    if not More(T) then
    return false;
    end if;
    return Is_Not_Literal(String_Pkg.Value(Chars), T);

end Is_Not_Literal;

----------------------------------------------------------------

procedure Scan_Not_Literal(
    Chars  : in     string;
    T      : in     Scanner;
    Found  :    out boolean;
    Result :    out String_Type;
    Skip   : in     boolean := false
    ) is

    N : natural;

begin

    if Skip then
    Skip_Space(T);
    end if;
    if Is_Not_Literal(Chars, T) then
    String_Pkg.Mark;
    N := String_Pkg.Match_S(T.text, Chars, T.index);
    Result := String_Pkg.Make_Persistent(String_Pkg.Substr(T.text, T.index, N - T.index));
    T.index := N;
    Found   := true;
    String_Pkg.Release;
    else
    Found := false;
    return;
    end if;

end Scan_Not_Literal;

----------------------------------------------------------------

procedure Scan_Not_Literal(
    Chars  : in     String_Type;
    T      : in     Scanner;
    Found  :    out boolean;
    Result :    out String_Type;
    Skip   : in     boolean := false
    ) is

begin

    Scan_Not_Literal(String_Pkg.Value(Chars), T, Found, Result, Skip);

end Scan_Not_Literal;


end String_Scanner;
--::::::::::
--tod.bdy
--::::::::::
with Search_Utilities;  -- Generic searching package.
package body Tod_Utilities is
  -- The type declarations below are used throughout the body to store
  -- time values.

  type Integer_Duration is range -86_400 .. 86_400;
  subtype Positive_Duration is Integer_Duration range
    1 .. Integer_Duration'LAST;
  subtype Natural_Duration is Integer_Duration range
    0 .. Integer_Duration'LAST;

  -- The constants below make for easy conversion of
  -- CALENDAR.DAY_DURATION values.

  Noon_Hour                   : constant Positive_Duration := 12;
  Number_of_Hours_in_Day      : constant Positive_Duration := 24;
  Number_of_Minutes_in_Hour   : constant Positive_Duration := 60;
  Number_of_Minutes_in_Day    : constant Positive_Duration :=
    Number_of_Minutes_in_Hour * Number_of_Hours_in_Day;
  Number_of_Seconds_in_Minute : constant Positive_Duration := 60;
  Number_of_Seconds_in_Hour   : constant Positive_Duration :=
    Number_of_Seconds_in_Minute * Number_of_Minutes_in_Hour;
  Number_of_Seconds_in_Day    : constant Positive_Duration :=
    Number_of_Seconds_in_Hour * Number_of_Hours_in_Day;
  Number_of_Days_in_a_Week    : constant Positive_Duration :=  7;
  Number_of_Months_in_a_Year  : constant Positive_Duration := 12;

  -- Constants needed to access the day name field of an external TOD
  -- representation.

  Day_Name_Start : constant POSITIVE := 1;
  Day_Name_End   : constant POSITIVE := 9;

  -- Constants to make the code more readable.

  Blank                         : constant CHARACTER := ' ';
  Colon                         : constant CHARACTER := ASCII.COLON;
  Period                        : constant CHARACTER := '.';
  Max_Legal_Letter_Token_Length : constant POSITIVE  := 9;
  Version_Number                : constant STRING    := "2.0 (THEB048)";
  AM_String                     : constant STRING    := "AM";
  PM_String                     : constant STRING    := "PM";
  UC_LC_Offset                  : constant NATURAL   :=
    CHARACTER'POS (ASCII.LC_A) - CHARACTER'POS ('A');

  -- Types/subtypes and constant array needed by both conversion functions.

  subtype Set_of_Upper_Case_Letters is CHARACTER range 'A' .. 'Z';
  subtype Search_Value_Type is STRING (1 .. Max_Legal_Letter_Token_Length);
  type Month_Name_Array_Type is array (INTEGER range <>) of
    Search_Value_Type;

  Month_Name_Array : constant Month_Name_Array_Type (CALENDAR.MONTH_NUMBER) :=
    ("JANUARY  ", "FEBRUARY ", "MARCH    ", "APRIL    ", "MAY      ",
     "JUNE     ", "JULY     ", "AUGUST   ", "SEPTEMBER", "OCTOBER  ",
     "NOVEMBER ", "DECEMBER ");

  function Version return STRING is
  begin
    return Version_Number;
  end Version;

  -- The function below uses an algorithm to derive the current day
  -- of the week given a date (in internal format).

  function Compute_Day_of_Week (Tod_Value : in CALENDAR.TIME)
    return Search_Value_Type is

    -- This function was designed by A. Spencer Peterson, SEI according
    -- to the author's specifications.  Only extremely minor changes
    -- were made to the algorithm by the author.

    -- The following constant hardcodes the algorithm to work at the
    -- reference point of 1984.  Other hardcoded constants in the
    -- code nail the exact day, 1/1/84, to Sunday.  If the reference
    -- point is changed, then so must the day names returned.

    Ref_Year : constant CALENDAR.YEAR_NUMBER := 1984;

    Number_of_Days_in_a_Leap_Year     : constant Positive_Duration := 366;
    Number_of_Days_in_a_Normal_Year   : constant Positive_Duration := 365;
    Number_of_Days_in_Feb_Leap_Year   : constant Positive_Duration :=  29;
    Number_of_Days_in_Feb_Normal_Year : constant Positive_Duration :=  28;
    Number_of_Days_in_Long_Months     : constant Positive_Duration :=  31;
    Number_of_Days_in_Short_Months    : constant Positive_Duration :=  30;

    February  : constant POSITIVE :=   2;
    April     : constant POSITIVE :=   4;
    June      : constant POSITIVE :=   6;
    September : constant POSITIVE :=   9;
    November  : constant POSITIVE :=  11;

    subtype Number_of_Days_Type is Integer_Duration
      range -Number_of_Days_in_a_Week + 1 .. Number_of_Days_in_a_Week - 1;

    First_Year,
    Last_Year,
    Input_Year           : CALENDAR.YEAR_NUMBER;
    Month_Count,
    Input_Month          : CALENDAR.MONTH_NUMBER;
    Input_Day            : CALENDAR.DAY_NUMBER;
    After_Ref_Year       : BOOLEAN;
    Constrained_Num_Days : Number_of_Days_Type;
    Number_of_Days       : Integer_Duration := 0;

    function Leap_Year (In_Year : in CALENDAR.YEAR_NUMBER) return BOOLEAN is
      Leap_Year_Century : constant POSITIVE := 400;
      Leap_Year_Offset  : constant POSITIVE :=   4;
      Century           : constant POSITIVE := 100;
    begin
      return (In_Year rem Leap_Year_Century = 0) or
             ((In_Year rem Leap_Year_Offset = 0) and
              (In_Year rem Century /= 0));
    end Leap_Year;
  begin  -- Compute_Day_of_Week
    -- Decode the CALENDAR.TIME into its subcomponents.

    Input_Year  := CALENDAR.YEAR (Tod_Value);
    Input_Month := CALENDAR.MONTH (Tod_Value);
    Input_Day   := CALENDAR.DAY (Tod_Value);

    -- Start of the algorithm follows below.

    if Input_Year < Ref_Year then
      After_Ref_Year := FALSE;
      First_Year     := Input_Year;
      Last_Year      := Ref_Year;
    else
      After_Ref_Year := TRUE;
      First_Year     := Ref_Year;
      Last_Year      := Input_Year;
    end if;

    while First_Year < Last_Year loop
      if Leap_Year (First_Year) then
        if After_Ref_Year then
          Number_of_Days := Number_of_Days + Number_of_Days_in_a_Leap_Year;
        else
          Number_of_Days := Number_of_Days - Number_of_Days_in_a_Leap_Year;
        end if;
      elsif After_Ref_Year then
        Number_of_Days := Number_of_Days + Number_of_Days_in_a_Normal_Year;
      else
        Number_of_Days := Number_of_Days - Number_of_Days_in_a_Normal_Year;
      end if;

      First_Year := First_Year + 1;
    end loop;

    Month_Count := 1;

    while Month_Count < Input_Month loop
      case Month_Count is
        when February =>
          if Leap_Year (Input_Year) then
            Number_of_Days := Number_of_Days + Number_of_Days_in_Feb_Leap_Year;
          else
            Number_of_Days := Number_of_Days +
              Number_of_Days_in_Feb_Normal_Year;
          end if;
        when April | June | September | November =>
          Number_of_Days := Number_of_Days + Number_of_Days_in_Short_Months;
        when others =>
          Number_of_Days := Number_of_Days + Number_of_Days_in_Long_Months;
      end case;

      Month_Count := Month_Count + 1;
    end loop;

    Constrained_Num_Days := (Number_of_Days +
      Integer_Duration (Input_Day)) rem Number_of_Days_in_a_Week;

    case Constrained_Num_Days is
      when -6 => return "SUNDAY   ";
      when -5 => return "MONDAY   ";
      when -4 => return "TUESDAY  ";
      when -3 => return "WEDNESDAY";
      when -2 => return "THURSDAY ";
      when -1 => return "FRIDAY   ";
      when  0 => return "SATURDAY ";
      when  1 => return "SUNDAY   ";  -- The algorithm is hardcoded on this day.
      when  2 => return "MONDAY   ";
      when  3 => return "TUESDAY  ";
      when  4 => return "WEDNESDAY";
      when  5 => return "THURSDAY ";
      when  6 => return "FRIDAY   ";
    end case;
  end Compute_Day_of_Week;

  -- The function below converts an internal CALENDAR.TIME value to
  -- an external STRING value.

  function Convert (
    Tod_Value       : in CALENDAR.TIME;
    Default_Setting : in Type_Set := UPPER_CASE)
    return External_Tod_Representation_Type is

    -- Constants for array positions of each component of the external
    -- representation type follow below.

    Day_Number_Start  : constant POSITIVE := 11;
    Day_Number_End    : constant POSITIVE := 12;
    Month_Name_Start  : constant POSITIVE := 14;
    Month_Name_End    : constant POSITIVE := 22;
    Year_Number_Start : constant POSITIVE := 24;
    Year_Number_End   : constant POSITIVE := 27;
    Time_Start        : constant POSITIVE := 29;
    Time_End          : constant POSITIVE := 38;
    Hour_Start        : constant POSITIVE := 29;
    Hour_End          : constant POSITIVE := 30;
    Minute_Start      : constant POSITIVE := 32;
    Minute_End        : constant POSITIVE := 33;
    Second_Start      : constant POSITIVE := 35;
    Second_End        : constant POSITIVE := 36;
    AMPM_Start        : constant POSITIVE := 37;
    AMPM_End          : constant POSITIVE := 38;

    Leading_Zero : constant CHARACTER := '0';

    subtype Double_Digits is Natural_Duration range 10 .. Natural_Duration'LAST;
    subtype Afternoon_or_Evening is Natural_Duration range
      Noon_Hour .. Number_of_Hours_in_Day - 1;

    Year               : CALENDAR.YEAR_NUMBER;
    Month              : CALENDAR.MONTH_NUMBER;
    Day                : CALENDAR.DAY_NUMBER;
    Seconds            : CALENDAR.DAY_DURATION;
    Curr_Hour          : Natural_Duration range 00 .. Number_of_Hours_in_Day;
    Curr_Minute        : Natural_Duration range
      00 .. Number_of_Minutes_in_Hour - 1;
    Curr_Second        : Natural_Duration range
      00 .. Number_of_Seconds_in_Minute - 1;
    Seconds_as_Natural : Natural_Duration range 0 .. Number_of_Seconds_in_Day;
    Temp_Value,
    Return_Value       : External_Tod_Representation_Type := (others => Blank);

    procedure Convert_Upper_Case_to_Lower_Case (Tod_Value : in out STRING) is
    begin
      for I in Tod_Value'RANGE loop
        if Tod_Value (I) in Set_of_Upper_Case_Letters then
          Tod_Value (I) := CHARACTER'VAL (CHARACTER'POS (Tod_Value(I)) +
            UC_LC_Offset);
        end if;
      end loop;
    end Convert_Upper_Case_to_Lower_Case;

    procedure Convert_Upper_Case_to_Mixed_Case (Tod_Value : in out STRING) is
    begin
      for I in Tod_Value'FIRST + 1 .. Tod_Value'LAST loop
        if (Tod_Value (I) in Set_of_Upper_Case_Letters) and
           (Tod_Value (I-1) /= Blank) then
          Tod_Value (I) := CHARACTER'VAL (CHARACTER'POS (Tod_Value (I)) +
            UC_LC_Offset);
        end if;
      end loop;

      -- Special case: AM/PM indicator.

      Tod_Value (AMPM_Start) := CHARACTER'VAL (CHARACTER'POS (Tod_Value (
        AMPM_Start)) - UC_LC_Offset);
    end Convert_Upper_Case_to_Mixed_Case;
  begin  -- Convert
    -- Store day of the week string.

    Return_Value (Day_Name_Start .. Day_Name_End) :=
      Compute_Day_of_Week (Tod_Value);

    -- Disect internal format into its components for our own use.

    CALENDAR.SPLIT (Tod_Value, Year, Month, Day, Seconds);

    -- Store day number value.

    if Natural_Duration (Day) in Double_Digits then
      Temp_Value (Day_Number_Start - 1 .. Day_Number_End) :=
        CALENDAR.DAY_NUMBER'IMAGE (Day);
      Return_Value (Day_Number_Start .. Day_Number_End) :=
        Temp_Value (Day_Number_Start .. Day_Number_End);
    else
      Temp_Value (Day_Number_End - 1 .. Day_Number_End) :=
        CALENDAR.DAY_NUMBER'IMAGE (Day);
      Return_Value (Day_Number_Start) := Leading_Zero;
      Return_Value (Day_Number_End) := Temp_Value (Day_Number_End);
    end if;

    -- Store the month name and year number.

    Return_Value (Month_Name_Start .. Month_Name_End) :=
      Month_Name_Array (Month);
    Temp_Value (Year_Number_Start - 1 .. Year_Number_End) :=
      CALENDAR.YEAR_NUMBER'IMAGE (Year);
    Return_Value (Year_Number_Start .. Year_Number_End) :=
      Temp_Value (Year_Number_Start .. Year_Number_End);

    -- Convert CALENDAR.DAY_DURATION value to Natural_Duration for easier
    -- calculations below.

    Seconds_as_Natural := Natural_Duration (Seconds);

    -- Compute the current hour, minutes, and seconds.

    Curr_Hour := (Seconds_as_Natural / Number_of_Minutes_in_Hour) /
      Number_of_Seconds_in_Minute;
    Curr_Minute := (Seconds_as_Natural / Number_of_Minutes_in_Hour) mod
      Number_of_Seconds_in_Minute;
    Curr_Second := Seconds_as_Natural -
      (Curr_Hour * Number_of_Seconds_in_Hour) -
      (Curr_Minute * Number_of_Minutes_in_Hour);

    -- Check for AM/PM in current hour and store AM/PM indication.

    if (Curr_Hour = 00) or (Curr_Hour = Number_of_Hours_in_Day) then
      Curr_Hour := Noon_Hour;  -- 00:00:00 === 12:00:00 AM === 24:00:00
      Return_Value (AMPM_Start .. AMPM_End) := AM_String;
    elsif (Curr_Hour in Afternoon_or_Evening) and (Curr_Hour /= Noon_Hour) then
      Curr_Hour := Curr_Hour - Noon_Hour;  -- Convert to AM/PM format.
      Return_Value (AMPM_Start .. AMPM_End) := PM_String;
    elsif Curr_Hour = Noon_Hour then
      Return_Value (AMPM_Start .. AMPM_End) := PM_String;
    else
      Return_Value (AMPM_Start .. AMPM_End) := AM_String;
    end if;

    -- Store current hour.

    if Curr_Hour in Double_Digits then
      Temp_Value (Hour_Start - 1 .. Hour_End) :=
        Natural_Duration'IMAGE (Curr_Hour);
      Return_Value (Hour_Start .. Hour_End) :=
        Temp_Value (Hour_Start .. Hour_End);
    else
      Temp_Value (Hour_End - 1 .. Hour_End) :=
        Natural_Duration'IMAGE (Curr_Hour);
      Return_Value (Hour_Start) := Leading_Zero;
      Return_Value (Hour_End) := Temp_Value (Hour_End);
    end if;

    Return_Value (Hour_End + 1) := Colon;

    -- Store current minutes.

    if Curr_Minute in Double_Digits then
      Temp_Value (Minute_Start - 1 .. Minute_End) :=
        Natural_Duration'IMAGE (Curr_Minute);
      Return_Value (Minute_Start .. Minute_End) :=
        Temp_Value (Minute_Start .. Minute_End);
    else
      Temp_Value (Minute_End - 1 .. Minute_End) :=
        Natural_Duration'IMAGE (Curr_Minute);
      Return_Value (Minute_Start) := Leading_Zero;
      Return_Value (Minute_End) := Temp_Value (Minute_End);
    end if;

    Return_Value (Minute_End + 1) := Colon;

    -- Store current seconds.

    if Curr_Second in Double_Digits then
      Temp_Value (Second_Start - 1 .. Second_End) :=
        Natural_Duration'IMAGE (Curr_Second);
      Return_Value (Second_Start .. Second_End) :=
        Temp_Value (Second_Start .. Second_End);
    else
      Temp_Value (Second_End - 1 .. Second_End) :=
        Natural_Duration'IMAGE (Curr_Second);
      Return_Value (Second_Start) := Leading_Zero;
      Return_Value (Second_End) := Temp_Value (Second_End);
    end if;

    -- Set non-default type set for the user.

    if Default_Setting = lower_case then
      Convert_Upper_Case_to_Lower_Case (Return_Value);
    elsif Default_Setting = Mixed_Case then
      Convert_Upper_Case_to_Mixed_Case (Return_Value);
    end if;

    -- We are done.  Return the external format to the user.

    return Return_Value;
  end Convert;

  -- The function below is equivalent to calling the
  -- above Convert function with an argument of Calendar.Clock
  -- to obtain the current date and time.
  function Now (Default_Setting : in TYPE_SET := UPPER_CASE)
    return EXTERNAL_TOD_REPRESENTATION_TYPE is
  begin -- Now
    return Convert (Calendar.Clock, Default_Setting);
  end Now;

  -- The function below converts an external format TOD to the Ada
  -- internal format, CALENDAR.TIME.

  function Convert (Tod_String : in STRING) return CALENDAR.TIME is
    Comma                     : constant CHARACTER     := ',';
    Minus                     : constant CHARACTER     := '-';
    Slash                     : constant CHARACTER     := '/';
    Current_Time              : constant CALENDAR.TIME := CALENDAR.CLOCK;
    Minimum_Tod_String_Length : constant POSITIVE      := 2;

    subtype Tod_Value_Length_Type is NATURAL range
      0 .. Tod_String'LENGTH;
    subtype Tod_Value_Pointer_Type is POSITIVE range
       Tod_String'FIRST .. Tod_String'LAST + 1;

    type Token_Type is (Day_as_Name, Day_as_Number, Month_Name_or_Number,
      Year_Number, Time_String, Special_Format);
    type Tokens_Specified_Array_Type is array (Token_Type) of BOOLEAN;

    Tod_Value                    : STRING (Tod_String'RANGE) := Tod_String;
    Tod_Value_Compressed_Length,
    Token_Length                 : Tod_Value_Length_Type;
    Token                        : STRING (Tod_Value'RANGE);
    Day_Name                     : Search_Value_Type;
    No_Token_Found               : BOOLEAN;
    Tod_Value_Pointer            : Tod_Value_Pointer_Type      :=
      Tod_Value'FIRST;
    Year                         : CALENDAR.YEAR_NUMBER        :=
      CALENDAR.YEAR (Current_Time);
    Month                        : CALENDAR.MONTH_NUMBER       :=
      CALENDAR.MONTH (Current_Time);
    Day                          : CALENDAR.DAY_NUMBER         :=
      CALENDAR.DAY (Current_Time);
    Seconds                      : CALENDAR.DAY_DURATION       :=
      CALENDAR.DAY_DURATION'FIRST;
    Return_Time_Value            : CALENDAR.TIME               :=
      CALENDAR.TIME_OF (Year, Month, Day, CALENDAR.DAY_DURATION'FIRST);
    Tokens_Specified_Array       : Tokens_Specified_Array_Type :=
      (others => FALSE);

    function "+" (Left : in CALENDAR.TIME; Right : in DURATION)
      return CALENDAR.TIME renames CALENDAR."+";
    function "-" (Left : in CALENDAR.TIME; Right : in DURATION)
      return CALENDAR.TIME renames CALENDAR."-";

    procedure Compress_External_Representation (
      Tod_Value                   : in out STRING;
      Tod_Value_Compressed_Length :    out Tod_Value_Length_Type) is

      Tod_Value_Copy         : STRING (Tod_Value'RANGE) := (others => Blank);
      Tod_Value_Pointer,
      Tod_Value_Pointer_Copy : Tod_Value_Pointer_Type := Tod_Value'FIRST;
    begin
      -- Change all commas to blanks and all minus signs to slash
      -- signs for easier parsing.

      for I in Tod_Value'RANGE loop
        if Tod_Value (I) = Comma then
          Tod_Value (I) := Blank;
        elsif Tod_Value (I) = Minus then
          Tod_Value (I) := Slash;
        end if;
      end loop;

      -- Skip over leading blanks.

      while (Tod_Value_Pointer <= Tod_Value'LAST) and then
            (Tod_Value(Tod_Value_Pointer) = Blank) loop
        Tod_Value_Pointer := Tod_Value_Pointer + 1;
      end loop;

      -- Skip over excessive number of blanks in the middle of
      -- the string.

      while (Tod_Value_Pointer <= Tod_Value'LAST - 2) loop
        if (Tod_Value (Tod_Value_Pointer)     = Blank) and
           (Tod_Value (Tod_Value_Pointer + 1) = Blank) and
           (Tod_Value (Tod_Value_Pointer + 2) = Blank) then
          Tod_Value_Pointer := Tod_Value_Pointer + 2;
        elsif (Tod_Value (Tod_Value_Pointer)     = Blank) and
              (Tod_Value (Tod_Value_Pointer + 1) = Blank) then
          Tod_Value_Pointer      := Tod_Value_Pointer      + 2;
          Tod_Value_Pointer_Copy := Tod_Value_Pointer_Copy + 1;
        elsif (Tod_Value (Tod_Value_Pointer) = Blank) then
          Tod_Value_Pointer      := Tod_Value_Pointer      + 1;
          Tod_Value_Pointer_Copy := Tod_Value_Pointer_Copy + 1;
        else
          Tod_Value_Copy (Tod_Value_Pointer_Copy) :=
            Tod_Value (Tod_Value_Pointer);
          Tod_Value_Pointer      := Tod_Value_Pointer      + 1;
          Tod_Value_Pointer_Copy := Tod_Value_Pointer_Copy + 1;
        end if;
      end loop;

      -- Now handle special cases near the end of the string.

      if (Tod_Value'FIRST + Tod_Value'LAST - 1 >= 3) and then
         ((Tod_Value (Tod_Value'LAST - 2) /= Blank) and
          (Tod_Value (Tod_Value'LAST - 1)  = Blank) and
          (Tod_Value (Tod_Value'LAST)     /= Blank)) then
        Tod_Value_Pointer_Copy := Tod_Value_Pointer_Copy + 1;
      end if;

      if (Tod_Value'FIRST + Tod_Value'LAST - 1 >= 2) and then
         (Tod_Value (Tod_Value'LAST - 1) /= Blank) then
        Tod_Value_Copy (Tod_Value_Pointer_Copy) :=
          Tod_Value (Tod_Value'LAST - 1);
        Tod_Value_Pointer_Copy := Tod_Value_Pointer_Copy + 1;
      end if;

      if (Tod_Value'FIRST + Tod_Value'LAST - 1 >= 1) and then
         (Tod_Value (Tod_Value'LAST) /= Blank) then
        Tod_Value_Copy (Tod_Value_Pointer_Copy) := Tod_Value (Tod_Value'LAST);
        Tod_Value_Pointer_Copy := Tod_Value_Pointer_Copy + 1;
      end if;

      -- Now return the compressed string and corresponding length.

      Tod_Value := Tod_Value_Copy;
      Tod_Value_Compressed_Length := Tod_Value_Pointer_Copy - Tod_Value'FIRST;
    end Compress_External_Representation;

    procedure Convert_External_Representation_to_Upper_Case (
      Tod_Value : in out STRING) is

      subtype Set_of_Lower_Case_Letters is CHARACTER range
        ASCII.LC_A .. ASCII.LC_Z;
    begin
      -- Loop on all characters in the compressed Tod_Value.  Modify
      -- all lower case letters to upper case.

      for I in Tod_Value'FIRST ..
               Tod_Value'FIRST + Tod_Value_Compressed_Length - 1 loop
        if Tod_Value (I) in Set_of_Lower_Case_Letters then
          Tod_Value (I) := CHARACTER'VAL (CHARACTER'POS (Tod_Value (I)) -
            UC_LC_Offset);
        end if;
      end loop;
    end Convert_External_Representation_to_Upper_Case;

    procedure Grab_a_Token (
      Tod_Value         : in     STRING;
      Tod_Value_Pointer : in out Tod_Value_Pointer_Type;
      Token             :    out STRING;
      Token_Length      :    out Tod_Value_Length_Type;
      No_Token_Found    :    out BOOLEAN) is

      Local_Token   : STRING (Token'RANGE)   := (others => Blank);
      Token_Pointer : Tod_Value_Pointer_Type := Local_Token'FIRST;
    begin
      -- Grab the next token.

      while (Tod_Value_Pointer <= Tod_Value_Compressed_Length +
             Tod_Value'FIRST - 1) and then
            (Tod_Value (Tod_Value_Pointer) /= Blank) loop
        Local_Token (Token_Pointer) := Tod_Value (Tod_Value_Pointer);
        Token_Pointer               := Token_Pointer + 1;
        Tod_Value_Pointer           := Tod_Value_Pointer + 1;
      end loop;

      -- Skip over that blank, but don't skip outside the bounds.

      if Tod_Value_Pointer < Tod_Value_Pointer_Type'LAST then
        Tod_Value_Pointer := Tod_Value_Pointer + 1;
      end if;

      -- Did we find a token?  Return T/F.  Also return the token and length.

      No_Token_Found := Local_Token (Local_Token'FIRST) = Blank;
      Token          := Local_Token;
      Token_Length   := Token_Pointer - Local_Token'FIRST;
    end Grab_a_Token;

    procedure Analyze_and_Process_Token (
      Token        : in      STRING;
      Token_Length : in      Tod_Value_Length_Type;
      Month_Only   : in      BOOLEAN) is

      Current_Century : constant POSITIVE :=
       (CALENDAR.YEAR (Current_Time) / 100) * 100;

      subtype Short_Year_Range is NATURAL range 0 .. 99;
      subtype Set_of_Numerics is CHARACTER range '0' .. '9';

      function Token_Contains_Illegal_Characters (
        Token        : in STRING;
        Token_Length : in Tod_Value_Length_Type) return BOOLEAN is

        Only_Legals : BOOLEAN := TRUE;  -- Assume the best.
      begin
        for I in Token'FIRST .. Token'FIRST + Token_Length - 1 loop
          Only_Legals := Only_Legals and
            ((Token (I) in Set_of_Upper_Case_Letters) or
             (Token (I) in Set_of_Numerics)           or
             (Token (I) = Colon)                      or
             (Token (I) = Period)                     or
             (Token (I) = Slash));
        end loop;

        return not Only_Legals;
      end Token_Contains_Illegal_Characters;

      function Token_Contains_Only_Letters (
        Token        : in STRING;
        Token_Length : in Tod_Value_Length_Type) return BOOLEAN is

        Only_Letters : BOOLEAN := TRUE;   -- Assume the best.
      begin
        for I in Token'FIRST .. Token'FIRST + Token_Length - 1 loop
          -- Check for a period in an abbreviation.  The period can only
          -- appear as the last character on the token, otherwise the
          -- token is illegal.

          if ((Token (I) = Period) and
              (I /= Token'FIRST + Token_Length - 1)) and then
             Token (I+1) /= Slash then
            raise Abbreviation_Error;
          end if;

          -- Now check to make sure that the current character being
          -- checked is a letter.

          Only_Letters := Only_Letters and
            ((Token (I) in Set_of_Upper_Case_Letters) or
             (Token (I) = Period));
        end loop;

        return Only_Letters;
      end Token_Contains_Only_Letters;

      function Token_Contains_No_Letters (
        Token        : in STRING;
        Token_Length : in Tod_Value_Length_Type) return BOOLEAN is

        No_Letters : BOOLEAN := TRUE;  -- Assume the best.
      begin
        for I in Token'FIRST .. Token'FIRST + Token_Length - 1 loop
          No_Letters := No_Letters and
                        (Token (I) not in Set_of_Upper_Case_Letters);
        end loop;

        return No_Letters;
      end Token_Contains_No_Letters;

      function Token_Contains_Only_Numerics (
        Token        : in STRING;
        Token_Length : in Tod_Value_Length_Type) return BOOLEAN is

        Only_Numerics : BOOLEAN := TRUE;  -- Assume the best.
      begin
        for I in Token'FIRST .. Token'FIRST + Token_Length - 1 loop
          Only_Numerics := Only_Numerics and (Token (I) in Set_of_Numerics);
        end loop;

        return Only_Numerics;
      end Token_Contains_Only_Numerics;

      function Token_Contains_Slash (
        Token        : in STRING;
        Token_Length : in Tod_Value_Length_Type) return BOOLEAN is

        Slash_Found : BOOLEAN := FALSE;  -- Assume the worst.
      begin
        for I in Token'FIRST .. Token'FIRST + Token_Length - 1 loop
          Slash_Found := Slash_Found or (Token (I) = Slash);
        end loop;

        return Slash_Found;
      end Token_Contains_Slash;

      function Token_Contains_Colon_and_Numerics_with_Optional_AMPM (
        Token        : in STRING;
        Token_Length : in Tod_Value_Length_Type) return BOOLEAN is

        Colon_Found : BOOLEAN := FALSE;  -- Assume the worst.
        Legal_Token : BOOLEAN := TRUE;   -- Assume the best.
      begin
        for I in Token'FIRST .. Token'FIRST + Token_Length - 3 loop
          if Token (I) /= Colon then
            Legal_Token := Legal_Token and (Token (I) in Set_of_Numerics);
          else
            Colon_Found := TRUE;
          end if;
        end loop;

        if Token_Length < 3 then
          Legal_Token := FALSE;
        elsif (Token (Token'FIRST + Token_Length - 2 ..
                      Token'FIRST + Token_Length - 1) /= AM_String) and
              (Token (Token'FIRST + Token_Length - 2 ..
                      Token'FIRST + Token_Length - 1) /= PM_String) then
          Legal_Token := Legal_Token and
            (Token (Token'FIRST + Token_Length - 2) in Set_of_Numerics);
          Legal_Token := Legal_Token and
            (Token (Token'FIRST + Token_Length - 1) in Set_of_Numerics);
        end if;

        return Legal_Token and Colon_Found;
      end Token_Contains_Colon_and_Numerics_with_Optional_AMPM;

      function Token_Contains_Numerics_and_AMPM (
        Token        : in STRING;
        Token_Length : in Tod_Value_Length_Type) return BOOLEAN is

        Legal_Token  : BOOLEAN := TRUE;  -- Assume the best.
      begin
        for I in Token'FIRST .. Token'FIRST + Token_Length - 3 loop
          Legal_Token := Legal_Token and (Token (I) in Set_of_Numerics);
        end loop;

        if (Token (Token'FIRST + Token_Length - 2 ..
                   Token'FIRST + Token_Length - 1) /= AM_String) and
           (Token (Token'FIRST + Token_Length - 2 ..
                   Token'FIRST + Token_Length - 1) /= PM_String) then
          Legal_Token := FALSE;
        end if;

        return Legal_Token;
      end Token_Contains_Numerics_and_AMPM;

      function Convert_Token_to_Proper_Length (Token : in STRING)
        return Search_Value_Type is

        Token_Copy : Search_Value_Type := (others => blank);
        I          : POSITIVE range Token'FIRST .. Token'FIRST +
          Max_Legal_Letter_Token_Length := Token'FIRST;
      begin
        while (I <= Token'FIRST + Max_Legal_Letter_Token_Length - 1) and
              (I <= Token'LAST) loop
          Token_Copy (I) := Token (I);
          I := I + 1;
        end loop;

        return Token_Copy;
      end Convert_Token_to_Proper_Length;

      procedure Analyze_and_Process_Day_Name_or_Month_Name_or_Special (
        Token        : in     STRING;
        Token_Length : in     Tod_Value_Length_Type;
        Month_Only   : in     BOOLEAN) is

        Location_Found         : POSITIVE;
        Component_Found,
        Abbreviation_Specified : BOOLEAN;
        Local_Token_Length     : Tod_Value_Length_Type := Token_Length;
        Local_Token            : Search_Value_Type     :=
          Convert_Token_to_Proper_Length (Token);

        -- Establish the arrays of possible days, months, and special
        -- components.

        Number_of_Day_Match_Components   : constant POSITIVE := 43;
        Number_of_Month_Match_Components : constant POSITIVE := 50;
        Number_of_Special_Components     : constant POSITIVE :=  4;

        type My_Array_Type is array (POSITIVE range <>) of
          Search_Value_Type;
        subtype Day_Match_Array_Index_Type is POSITIVE range
          1 .. Number_of_Day_Match_Components;
        subtype Month_Match_Array_Index_Type is POSITIVE range
          1 .. Number_of_Month_Match_Components;
        subtype Specials_Array_Index_Type is POSITIVE range
          1 .. Number_of_Special_Components;

        Day_Match_Array : constant My_Array_Type (Day_Match_Array_Index_Type) :=
          ("SU       ", "SUN      ", "SUND     ", "SUNDA    ", "SUNDAY   ",
           "MO       ", "MON      ", "MOND     ", "MONDA    ", "MONDAY   ",
           "TU       ", "TUE      ", "TUES     ", "TUESD    ", "TUESDA   ",
           "TUESDAY  ", "WE       ", "WED      ", "WEDN     ", "WEDNE    ",
           "WEDNES   ", "WEDNESD  ", "WEDNESDA ", "WEDNESDAY", "TH       ",
           "THU      ", "THUR     ", "THURS    ", "THURSD   ", "THURSDA  ",
           "THURSDAY ", "FR       ", "FRI      ", "FRID     ", "FRIDA    ",
           "FRIDAY   ", "SA       ", "SAT      ", "SATU     ", "SATUR    ",
           "SATURD   ", "SATURDA  ", "SATURDAY ");

        Month_Match_Array : constant My_Array_Type (Month_Match_Array_Index_Type) :=
          ("JAN      ", "JANU     ", "JANUA    ", "JANUAR   ", "JANUARY  ",
           "FEB      ", "FEBR     ", "FEBRU    ", "FEBRUA   ", "FEBRUAR  ",
           "FEBRUARY ", "MAR      ", "MARC     ", "MARCH    ", "APR      ",
           "APRI     ", "APRIL    ", "MAY      ", "JUN      ", "JUNE     ",
           "JUL      ", "JULY     ", "AUG      ", "AUGU     ", "AUGUS    ",
           "AUGUST   ", "SEP      ", "SEPT     ", "SEPTE    ", "SEPTEM   ",
           "SEPTEMB  ", "SEPTEMBE ", "SEPTEMBER", "OCT      ", "OCTO     ",
           "OCTOB    ", "OCTOBE   ", "OCTOBER  ", "NOV      ", "NOVE     ",
           "NOVEM    ", "NOVEMB   ", "NOVEMBE  ", "NOVEMBER ", "DEC      ",
           "DECE     ", "DECEM    ", "DECEMB   ", "DECEMBE  ", "DECEMBER ");

        subtype Sundays is POSITIVE range 1 .. 5;
        subtype Mondays is POSITIVE range 6 .. 10;
        subtype Tuesdays is POSITIVE range 11 .. 16;
        subtype Wednesdays is POSITIVE range 17 .. 24;
        subtype Thursdays is POSITIVE range 25 .. 31;
        subtype Fridays is POSITIVE range 32 .. 36;
        subtype Saturdays is POSITIVE range 37 .. 43;
        subtype Januarys is POSITIVE range 1 .. 5;
        subtype Februarys is POSITIVE range 6 .. 11;
        subtype Marchs is POSITIVE range 12 .. 14;
        subtype Aprils is POSITIVE range 15 .. 17;
        subtype Mays is POSITIVE range 18 .. 18;
        subtype Junes is POSITIVE range 19 .. 20;
        subtype Julys is POSITIVE range 21 .. 22;
        subtype Augusts is POSITIVE range 23 .. 26;
        subtype Septembers is POSITIVE range 27 .. 33;
        subtype Octobers is POSITIVE range 34 .. 38;
        subtype Novembers is POSITIVE range 39 .. 44;
        subtype Decembers is POSITIVE range 45 .. 50;

        Specials_Array : constant My_Array_Type(Specials_Array_Index_Type) :=
          ("NOW      ", "TODAY    ", "TOMORROW ", "YESTERDAY");

        -- Establish an instantiation of the generic search package.

        package Search_For_Month_or_Day_Name_or_Specials is new
          Search_Utilities (
            Component_Type => Search_Value_Type,
            Index_Type     => POSITIVE,
            Array_Type     => My_Array_Type);

        procedure Analyze_and_Process_Day_Name (
          Token                  : in     STRING;
          Location_Found         : in     Day_Match_Array_Index_Type;
          Abbreviation_Specified : in     BOOLEAN) is
        begin
          -- Check to see if the day name has already been specified.

          if Tokens_Specified_Array (Day_as_Name) then
            raise Duplication_Error;
          end if;

          Tokens_Specified_Array (Day_as_Name) := TRUE;

          -- Now check to make sure that a period did not follow a full name.

          if Abbreviation_Specified then
            declare
              type Array_Type is array (Positive_Duration range <>) of
                Search_Value_Type;

              Days_Array : constant Array_Type (1 .. Number_of_Days_in_a_Week) :=
                ("SUNDAY   ", "MONDAY   ", "TUESDAY  ", "WEDNESDAY",
                 "THURSDAY ", "FRIDAY   ", "SATURDAY ");

              package Search_For_Full_Day_Name is new Search_Utilities (
                Component_Type => Search_Value_Type,
                Index_Type     => Positive_Duration,
                Array_Type     => Array_Type);
            begin
              if Search_For_Full_Day_Name.Search (
                   Component    => Token,
                   Search_Array => Days_Array) then
                raise Abbreviation_Error;
              end if;
            end;
          end if;

          -- Now store the day name for future processing.

          case Location_Found is
            when Sundays    => Day_Name := "SUNDAY   ";
            when Mondays    => Day_Name := "MONDAY   ";
            when Tuesdays   => Day_Name := "TUESDAY  ";
            when Wednesdays => Day_Name := "WEDNESDAY";
            when Thursdays  => Day_Name := "THURSDAY ";
            when Fridays    => Day_Name := "FRIDAY   ";
            when Saturdays  => Day_Name := "SATURDAY ";
          end case;
        end Analyze_and_Process_Day_Name;

        procedure Analyze_and_Process_Month_Name (
          Token                  : in     STRING;
          Location_Found         : in     Month_Match_Array_Index_Type;
          Abbreviation_Specified : in     BOOLEAN) is
        begin
          -- Check to see if the month name has already been specified.

          if Tokens_Specified_Array (Month_Name_or_Number) then
            raise Duplication_Error;
          end if;

          Tokens_Specified_Array (Month_Name_or_Number) := TRUE;

          -- Now check to make sure that a period did not follow a full name.

          if Abbreviation_Specified then
            declare
              package Search_For_Full_Month_Name is new Search_Utilities (
                Component_Type => Search_Value_Type,
                Index_Type     => INTEGER,
                Array_Type     => Month_Name_Array_Type);
            begin
              if Search_For_Full_Month_Name.Search (
                   Component    => Token,
                   Search_Array => Month_Name_Array) then
                raise Abbreviation_Error;
              end if;
            end;
          end if;

          -- Now store the month number.

          case Location_Found is
            when Januarys   => Month :=  1;
            when Februarys  => Month :=  2;
            when Marchs     => Month :=  3;
            when Aprils     => Month :=  4;
            when Mays       => Month :=  5;
            when Junes      => Month :=  6;
            when Julys      => Month :=  7;
            when Augusts    => Month :=  8;
            when Septembers => Month :=  9;
            when Octobers   => Month := 10;
            when Novembers  => Month := 11;
            when Decembers  => Month := 12;
          end case;
        end Analyze_and_Process_Month_Name;

        procedure Analyze_and_Process_Special (
          Token                  : in STRING;
          Abbreviation_Specified : in BOOLEAN) is
        begin
          -- Check to see if the special element has already been
          -- specified or if an illegal period was specified.

          if Tokens_Specified_Array (Special_Format) then
            raise Duplication_Error;
          elsif Abbreviation_Specified then
            raise Abbreviation_Error;
          end if;

          Tokens_Specified_Array (Special_Format) := TRUE;

          if Token (Token'FIRST..Token'FIRST +
                    Max_Legal_Letter_Token_Length - 1) = "NOW      " then
            Return_Time_Value := CALENDAR.CLOCK;
          elsif Token (Token'FIRST .. Token'FIRST +
                       Max_Legal_Letter_Token_Length - 1) = "YESTERDAY" then
            Return_Time_Value :=
              CALENDAR.TIME_OF (Year, Month, Day, Seconds) -
              CALENDAR.DAY_DURATION'LAST;
          elsif Token (Token'FIRST .. Token'FIRST +
                       Max_Legal_Letter_Token_Length - 1) = "TOMORROW " then
            Return_Time_Value :=
              CALENDAR.TIME_OF (Year, Month, Day, Seconds) +
              CALENDAR.DAY_DURATION'LAST;
          end if;

          -- Now store the components of this internal format so that
          -- they may be used later.

          Year  := CALENDAR.YEAR (Return_Time_Value);
          Month := CALENDAR.MONTH (Return_Time_Value);
          Day   := CALENDAR.DAY (Return_Time_Value);
        end Analyze_and_Process_Special;
      begin
        -- Check for illegal tokens that are too long.

        if Token_Length > Max_Legal_Letter_Token_Length then
          raise External_Representation_Error;
        end if;

        -- Check to see if an abbreviation has been given.

        if Local_Token (Local_Token'FIRST + Token_Length - 1) /= Period then
          Abbreviation_Specified := FALSE;
        else
          Local_Token (Local_Token'FIRST + Local_Token_Length - 1) := Blank;
          Local_Token_Length := Local_Token_Length - 1;
          Abbreviation_Specified := TRUE;
        end if;

        -- Search the array of day names.

        Search_For_Month_or_Day_Name_or_Specials.Search (
          Component       => Local_Token,
          Search_Array    => Day_Match_Array,
          Location_Found  => Location_Found,
          Component_Found => Component_Found);

        if Component_Found and (not Month_Only) then
          Analyze_and_Process_Day_Name (Local_Token, Location_Found,
            Abbreviation_Specified);
        else
          -- Search the array of month names.

          Search_For_Month_or_Day_Name_or_Specials.Search (
            Component       => Local_Token,
            Search_Array    => Month_Match_Array,
            Location_Found  => Location_Found,
            Component_Found => Component_Found);

          if Component_Found then
            Analyze_and_Process_Month_Name (Local_Token, Location_Found,
              Abbreviation_Specified);
          else
            -- Search the array of special formats.

            Search_For_Month_or_Day_Name_or_Specials.Search (
              Component       => Local_Token,
              Search_Array    => Specials_Array,
              Location_Found  => Location_Found,
              Component_Found => Component_Found);

            if Component_Found and not Month_Only then
              Analyze_and_Process_Special (Local_Token,
                Abbreviation_Specified);
            else
              raise External_Representation_Error;
            end if;
          end if;
        end if;
      end Analyze_and_Process_Day_Name_or_Month_Name_or_Special;

      procedure Analyze_and_Process_Day_Number_or_Year_Number (
        Token        : in     STRING;
        Token_Length : in     Tod_Value_Length_Type) is

        Temp_Value : NATURAL;
      begin
        begin
          Temp_Value := NATURAL'VALUE (Token);
        exception
          when CONSTRAINT_ERROR => raise External_Representation_Error;
        end;

        -- Is the number legal?  If so, store the year/day.

        if (Temp_Value not in Short_Year_Range) and
           (Temp_Value not in CALENDAR.YEAR_NUMBER) then
          raise External_Representation_Error;
        end if;

        if Temp_Value in CALENDAR.YEAR_NUMBER then
          if Tokens_Specified_Array (Year_Number) then
            raise Duplication_Error;
          elsif (Tokens_Specified_Array (Month_Name_or_Number) and
                 (not Tokens_Specified_Array (Day_as_Number))) or
                (Tokens_Specified_Array (Day_as_Number) and
                 (not Tokens_Specified_Array (Month_Name_or_Number))) then
            raise External_Representation_Error;
          end if;

          Tokens_Specified_Array (Year_Number) := TRUE;
          Year := Temp_Value;
        elsif (not Tokens_Specified_Array (Day_as_Number)) and
              (Temp_Value in CALENDAR.DAY_NUMBER) then
          Tokens_Specified_Array (Day_as_Number) := TRUE;
          Day := Temp_Value;
        elsif Tokens_Specified_Array (Year_Number) or
              (not Tokens_Specified_Array (Month_Name_or_Number)) or
              (not Tokens_Specified_Array (Day_as_Number)) then
          raise External_Representation_Error;
        else
          Tokens_Specified_Array (Year_Number) := TRUE;

          -- Special current century check: 00 = 2000 (20th century).

          if (Temp_Value = 00) and (Current_Century = 1900) then
            Year := 2000;
          else
            Year := Current_Century + Temp_Value;
          end if;
        end if;
      end Analyze_and_Process_Day_Number_or_Year_Number;

      procedure Analyze_and_Process_Date (
        Token        : in     STRING;
        Token_Length : in     Tod_Value_Length_Type) is

        procedure Analyze_and_Process_Numeric_Date (
          Token        : in STRING;
          Token_Length : in Tod_Value_Length_Type) is

          Curr_Month,
          Curr_Day,
          Curr_Year            : NATURAL;
          Temp_String          : STRING (Token'RANGE) := (others => Blank);
          Temp_String_Pointer,
          Token_Pointer        : Tod_Value_Pointer_Type := Token'FIRST;
        begin
          if Tokens_Specified_Array (Month_Name_or_Number) then
            raise Duplication_Error;
          end if;

          Tokens_Specified_Array (Month_Name_or_Number) := TRUE;

          -- Grab the month.  We should only find 1 or 2 characters.

          while (Token_Pointer <= Token'FIRST + Token_Length - 1) and then
                (Token (Token_Pointer) /= Slash) loop
            Temp_String (Temp_String_Pointer) := Token (Token_Pointer);
            Token_Pointer                     := Token_Pointer + 1;
            Temp_String_Pointer               := Temp_String_Pointer + 1;
          end loop;

          if (Temp_String_Pointer > Temp_String'FIRST + 2) or
             (Temp_String_Pointer = Temp_String'FIRST) then
            raise Month_Number_Error;
          end if;

          -- Store the month and check its range.

          begin
            Curr_Month := NATURAL'VALUE (Temp_String);
          exception
            when CONSTRAINT_ERROR => raise Month_Number_Error;
          end;

          if Curr_Month not in CALENDAR.MONTH_NUMBER then
            raise Month_Number_Error;
          else
            Month := Curr_Month;
          end if;

          if Tokens_Specified_Array (Day_as_Number) then
            raise Duplication_Error;
          end if;

          Tokens_Specified_Array (Day_as_Number) := TRUE;

          -- Grab the day.  Procedure is the same as above.

          Token_Pointer       := Token_Pointer + 1;  -- Bump past slash.
          Temp_String         := (others => Blank);
          Temp_String_Pointer := Temp_String'FIRST;

          while (Token_Pointer <= Token'FIRST + Token_Length - 1) and then
                (Token (Token_Pointer) /= Slash) loop
            Temp_String (Temp_String_Pointer) := Token (Token_Pointer);
            Token_Pointer                     := Token_Pointer + 1;
            Temp_String_Pointer               := Temp_String_Pointer + 1;
          end loop;

          if (Temp_String_Pointer > Temp_String'FIRST + 2) or
             (Temp_String_Pointer = Temp_String'FIRST) then
            raise Day_Number_Error;
          end if;

          -- Store the day and check its range.

          begin
            Curr_Day := NATURAL'VALUE (Temp_String);
          exception
            when CONSTRAINT_ERROR => raise Day_Number_Error;
          end;

          if Curr_Day not in CALENDAR.DAY_NUMBER then
            raise Day_Number_Error;
          else
            Day := Curr_Day;
          end if;

          -- Grab the year.  Procedure is the same as above.
          -- Year is optional, so check for this first.

          if (Token_Pointer <= Token'FIRST + Token_Length - 1) and then
             (Token (Token_Pointer) = Slash) then
            if Tokens_Specified_Array (Year_Number) then
              raise Duplication_Error;
            end if;

            Tokens_Specified_Array (Year_Number) := TRUE;

            Token_Pointer       := Token_Pointer + 1;
            Temp_String         := (others => Blank);
            Temp_String_Pointer := Temp_String'FIRST;

            while (Token_Pointer <= Token'FIRST + Token_Length - 1) and then
                  (Token (Token_Pointer) /= Slash) loop
              Temp_String (Temp_String_Pointer) := Token (Token_Pointer);
              Token_Pointer                     := Token_Pointer + 1;
              Temp_String_Pointer               := Temp_String_Pointer + 1;
            end loop;

            if (Temp_String_Pointer > Temp_String'FIRST + 4) or
               (Temp_String_Pointer = Temp_String'FIRST) then
              raise Year_Error;
            end if;

            -- Store the year and check its range.

            begin
              Curr_Year := NATURAL'VALUE (Temp_String);
            exception
              when CONSTRAINT_ERROR => raise Year_Error;
            end;

            if (Curr_Year not in CALENDAR.YEAR_NUMBER) and
               (Curr_Year not in Short_Year_Range) then
              raise Year_Error;
            end if;

            if Curr_Year in Short_Year_Range then
              -- Special current century check: 00 = 2000 (20th century).

              if (Curr_Year = 00) and (Current_Century = 1900) then
                Curr_Year := 2000;
              else
                Curr_Year := Current_Century + Curr_Year;
              end if;

              -- Special check on the year 1900.

              if Curr_Year = CALENDAR.YEAR_NUMBER'FIRST - 1 then
                raise Year_Error;
              end if;
            end if;

            Year := Curr_Year;
          end if;
        end Analyze_and_Process_Numeric_Date;

        procedure Analyze_and_Process_Combination_Date (
          Tod_Value        : in     STRING;
          Tod_Value_Length : in     Tod_Value_Length_Type) is

          Local_Token        : STRING (Tod_Value'RANGE);
          Local_Token_Length : Tod_Value_Length_Type;
          No_Token_Found     : BOOLEAN;
          Local_Tod_Value    : STRING (Tod_Value'RANGE) := Tod_Value;
          Tod_Value_Pointer  : Tod_Value_Pointer_Type := Local_Tod_Value'FIRST;
        begin
          -- Eliminate the slash sign(s).  Replace them with blanks.

          for I in Local_Tod_Value'FIRST ..
                   Local_Tod_Value'FIRST + Tod_Value_Length - 1 loop
            if Local_Tod_Value (I) = Slash then
              Local_Tod_Value (I) := Blank;
            end if;
          end loop;

          -- Now process each "token" in turn.  Note the recursion.

          loop
            Grab_a_Token (Local_Tod_Value, Tod_Value_Pointer,
              Local_Token, Local_Token_Length, No_Token_Found);

            exit when No_Token_Found;

            Analyze_and_Process_Token (Local_Token, Local_Token_Length, TRUE);
          end loop;
        end Analyze_and_Process_Combination_Date;
      begin
        -- Check to see if we are dealing with only numerics or not.

        if Token_Contains_No_Letters (Token, Token_Length) then
          Analyze_and_Process_Numeric_Date (Token, Token_Length);
        else
          Analyze_and_Process_Combination_Date (Token, Token_Length);
        end if;
      end Analyze_and_Process_Date;

      procedure Analyze_and_Process_Time (
        Token        : in     STRING;
        Token_Length : in     Tod_Value_Length_Type;
        Hour_Only    : in     BOOLEAN) is

        Min_HourAMPM_Length : constant POSITIVE :=  3;
        Max_HourAMPM_Length : constant POSITIVE :=  4;
        Min_Time_Length     : constant POSITIVE :=  3;
        Max_Time_Length     : constant POSITIVE := 10;

        subtype Hour_AMPM_Range is Positive_Duration range 01 .. Noon_Hour;
        Curr_Hour            : Natural_Duration;
        Curr_Minute,
        Curr_Second          : Natural_Duration := 00;
        Seconds_as_Natural   : Natural_Duration range
          0 .. Number_of_Seconds_in_Day;
        Temp_String          : STRING (Token'RANGE) := (others => Blank);
        Temp_String_Pointer,
        Token_Pointer        : Tod_Value_Pointer_Type := Token'FIRST;
        Special_Hour_Check   : BOOLEAN;
      begin
        if Tokens_Specified_Array (Time_String) then
          raise Duplication_Error;
        end if;

        Tokens_Specified_Array (Time_String) := TRUE;

        -- Check to see if only the hour was specified.

        if Hour_Only then
          -- Check length.  Should be either 3 or 4 characters.

          if (Token_Length < Min_HourAMPM_Length) or
             (Token_Length > MAx_HourAMPM_Length) then
            raise Time_String_Error;
          end if;

          -- Grab the hour.  Store in temporary string.

          while Token (Token_Pointer) in Set_of_Numerics loop
            Temp_String (Temp_String_Pointer) := Token (Token_Pointer);
            Token_Pointer                     := Token_Pointer + 1;
            Temp_String_Pointer               := Temp_String_Pointer + 1;
          end loop;

          -- Decode the hour and check the range.

          begin
            Curr_Hour := Natural_Duration'VALUE (Temp_String);
          exception
            when CONSTRAINT_ERROR => raise Hour_Error;
          end;

          if Curr_Hour not in Hour_AMPM_Range then
            raise Hour_Error;
          end if;

          -- Set hours to AM/PM indicator.

          if Curr_Hour = Noon_Hour then
            if Token (Token_Pointer .. Token_Pointer + 1) = AM_String then
              Curr_Hour := 00;
            else
              Curr_Hour := Noon_Hour;
            end if;
          elsif Token (Token_Pointer .. Token_Pointer + 1) = PM_String then
            Curr_Hour := Curr_Hour + Noon_Hour;
          end if;
        else
          -- Check length.  Should be between 3 and 10.

          if (Token_Length < Min_Time_Length) or
             (Token_Length > Max_Time_Length) then
            raise Time_String_Error;
          end if;

          -- Grab the hours.  Should only find 1 or 2 characters, both
          -- numerics.

          while (Token_Pointer <= Token'FIRST + Token_Length - 1) and then
                (Token (Token_Pointer) /= Colon) loop
            Temp_String (Temp_String_Pointer) := Token (Token_Pointer);
            Temp_String_Pointer               := Temp_String_Pointer + 1;
            Token_Pointer                     := Token_Pointer + 1;
          end loop;

          if (Temp_String_Pointer > Temp_String'FIRST + 2) or
             (Temp_String_Pointer = Temp_String'FIRST) then
            raise Hour_Error;
          end if;

          -- Store the number of hours and check its range.

          begin
            Curr_Hour := Natural_Duration'VALUE (Temp_String);
          exception
            when CONSTRAINT_ERROR => raise Hour_Error;
          end;

          if Curr_Hour not in 00 .. Number_of_Hours_in_Day then
            raise Hour_Error;
          end if;

          if Curr_Hour /= Number_of_Hours_in_Day then
            Special_Hour_Check := FALSE;
          else
            Special_Hour_Check := TRUE;
            Curr_Hour := 00;
          end if;

          -- Grab the minutes.  Procedure is the same as above.

          Token_Pointer       := Token_Pointer + 1;  -- Bump past colon.
          Temp_String         := (others => Blank);
          Temp_String_Pointer := Temp_String'FIRST;

          while (Token_Pointer <= Token'FIRST + Token_Length - 1) and then
                ((Token (Token_Pointer) /= Colon)                 and
                 (Token (Token_Pointer) /= 'A')                   and
                 (Token (Token_Pointer) /= 'P')) loop
            Temp_String (Temp_String_Pointer) := Token (Token_Pointer);
            Temp_String_Pointer := Temp_String_Pointer + 1;
            Token_Pointer := Token_Pointer + 1;
          end loop;

          if Temp_String_Pointer /= Temp_String'FIRST + 2 then
            raise Minute_Error;
          end if;

          -- Store the number of minutes and check its range.

          begin
            Curr_Minute := Natural_Duration'VALUE (Temp_String);
          exception
            when CONSTRAINT_ERROR => raise Minute_Error;
          end;

          if Curr_Minute not in 00 .. Number_of_Minutes_in_Hour - 1 then
            raise Minute_Error;
          end if;

          -- Grab the seconds.  Procedure is the same as above.
          -- seconds are optional, so check for this first.

          if (Token_Pointer <= Token'FIRST + Token_Length - 1) and then
             (Token(Token_Pointer) = Colon) then
            Token_Pointer       := Token_Pointer + 1;  -- Bump past colon.
            Temp_String         := (others => Blank);
            Temp_String_Pointer := Temp_String'FIRST;

            while (Token_Pointer <= Token'FIRST + Token_Length - 1) and then
                  ((Token (Token_Pointer) /= 'A')                   and
                   (Token (Token_Pointer) /= 'P')) loop
              if Token (Token_Pointer) = Colon then
                raise Time_String_Error;
              end if;

              Temp_String (Temp_String_Pointer) := Token (Token_Pointer);
              Temp_String_Pointer               := Temp_String_Pointer + 1;
              Token_Pointer                     := Token_Pointer + 1;
            end loop;

            if Temp_String_Pointer /= Temp_String'FIRST + 2 then
              raise Second_Error;
            end if;

            -- Store the number of seconds and check its range.

            begin
              Curr_Second := Natural_Duration'VALUE (Temp_String);
            exception
              when CONSTRAINT_ERROR => raise Second_Error;
            end;

            if Curr_Second not in 00 .. Number_of_Seconds_in_Minute - 1 then
              raise Second_Error;
            end if;
          end if;

          -- Check for optional AM/PM and check against hours specified.

          if (Token_Pointer /= Token'FIRST + Token_Length - 2) and
             (Token_Pointer /= Token'FIRST + Token_Length) then
            raise Time_String_Error;
          end if;

           if Token_Pointer = Token'FIRST + Token_Length - 2 then
             if Curr_Hour not in Hour_AMPM_Range then
               raise Hour_Error;
             end if;

            if Curr_Hour = Noon_Hour then
              if Token (Token'FIRST + Token_Length - 2 ..
                        Token'FIRST + Token_Length - 1) = AM_String then
                Curr_Hour := 00;
              else
                Curr_Hour := Noon_Hour;
              end if;
            elsif Token (Token'FIRST + Token_Length - 2 ..
                         Token'FIRST + Token_Length - 1) = PM_String then
              Curr_Hour := Curr_Hour + Noon_Hour;
            end if;
          end if;
        end if;

        -- Check for illegal time formats with hours equal to 24.

        if Special_Hour_Check and
           ((Curr_Minute /= 00) or (Curr_Second /= 00)) then
          raise Time_String_Error;
        end if;

        -- Compute the number of seconds given the components.

        Seconds_as_Natural := (Curr_Hour * Number_of_Seconds_in_Minute *
          Number_of_Minutes_in_Hour) +
          (Curr_Minute * Number_of_Seconds_in_Minute) + Curr_Second;

        Seconds := CALENDAR.DAY_DURATION (Seconds_as_Natural);
      end Analyze_and_Process_Time;
    begin  -- Analyze_and_Process_Token
      -- Determine what type of token we have.  See if the token contains
      -- only numerics, letters, etc.  Call the appropriate action
      -- routine once we have figured out what the token can be.  Also,
      -- if the token is not of any type that we can recognize, then
      -- raise External_Representation_Error.

      if Token_Contains_Illegal_Characters (Token, Token_Length) then
        raise External_Representation_Error;
      elsif Token_Contains_Only_Letters (Token, Token_Length) then
        Analyze_and_Process_Day_Name_or_Month_Name_or_Special (Token,
          Token_Length, Month_Only);
      elsif Token_Contains_Only_Numerics (Token, Token_Length) then
        Analyze_and_Process_Day_Number_or_Year_Number (Token, Token_Length);
      elsif Token_Contains_Slash (Token, Token_Length) then
        Analyze_and_Process_Date (Token, Token_Length);
      elsif Token_Contains_Colon_and_Numerics_with_Optional_AMPM (Token,
              Token_Length) then
        Analyze_and_Process_Time(Token, Token_Length, FALSE);
      elsif Token_Contains_Numerics_and_AMPM (Token, Token_Length) then
        Analyze_and_Process_Time (Token, Token_Length, TRUE);
      else
        raise External_Representation_Error;
      end if;
    end Analyze_and_Process_Token;

    procedure Compute_Current_or_Next_Future_Date_For_a_Day_Name is
      Tod_String           : External_Tod_Representation_Type :=
        Convert (Current_Time);
      Offset               : Natural_Duration range
        0 .. Number_of_Days_in_a_Week - 1;
      Target_Day_Position,
      Current_Day_Position : Positive_Duration range
        1 .. Number_of_Days_in_a_Week;
    begin
      -- Store the current day position.

      if Tod_String (Day_Name_Start .. Day_Name_End) = "SUNDAY   " then
        Current_Day_Position := 1;
      elsif Tod_String (Day_Name_Start .. Day_Name_End) = "MONDAY   " then
        Current_Day_Position := 2;
      elsif Tod_String (Day_Name_Start .. Day_Name_End) = "TUESDAY  " then
        Current_Day_Position := 3;
      elsif Tod_String (Day_Name_Start .. Day_Name_End) = "WEDNESDAY" then
        Current_Day_Position := 4;
      elsif Tod_String (Day_Name_Start .. Day_Name_End) = "THURSDAY " then
        Current_Day_Position := 5;
      elsif Tod_String (Day_Name_Start .. Day_Name_End) = "FRIDAY   " then
        Current_Day_Position := 6;
      else  -- SATURDAY
        Current_Day_Position := 7;
      end if;

      -- Store the target day position.

      if Day_Name = "SUNDAY   " then
        Target_Day_Position := 1;
      elsif Day_Name = "MONDAY   " then
        Target_Day_Position := 2;
      elsif Day_Name = "TUESDAY  " then
        Target_Day_Position := 3;
      elsif Day_Name = "WEDNESDAY" then
        Target_Day_Position := 4;
      elsif Day_Name = "THURSDAY " then
        Target_Day_Position := 5;
      elsif Day_Name = "FRIDAY   " then
        Target_Day_Position := 6;
      else  -- SATURDAY
        Target_Day_Position := 7;
      end if;

      -- Compute the offset.

      if Current_Day_Position = Target_Day_Position then
        Offset := 0;
      elsif Current_Day_Position < Target_Day_Position then
        Offset := Target_Day_Position - Current_Day_Position;
      else
        Offset := (Number_of_Days_in_a_Week - Current_Day_Position) +
          Target_Day_Position;
      end if;

      -- Recompute Return_Time_Value if a future date was specified.

      for I in 1 .. Offset loop
        if Seconds /= CALENDAR.DAY_DURATION'FIRST then
          Return_Time_Value := CALENDAR.TIME_OF (Year, Month, Day, Seconds) +
            CALENDAR.DAY_DURATION'LAST;
        else
          Return_Time_Value := CALENDAR.TIME_OF (Year, Month, Day,
            CALENDAR.DAY_DURATION'FIRST) + CALENDAR.DAY_DURATION'LAST + 1.0;
        end if;

        Year  := CALENDAR.YEAR (Return_Time_Value);
        Month := CALENDAR.MONTH (Return_Time_Value);
        Day   := CALENDAR.DAY (Return_Time_Value);

        if Seconds = CALENDAR.DAY_DURATION'FIRST then
          Return_Time_Value := CALENDAR.TIME_OF (Year, Month, Day,
            CALENDAR.DAY_DURATION'FIRST);
        end if;
      end loop;
    end Compute_Current_or_Next_Future_Date_For_a_Day_Name;

    procedure Perform_Error_Checking_and_Wrap_Up_Loose_Ends is
    begin
      -- If a day name and date were specified, make sure that the
      -- day name is correct for that date.

      if Tokens_Specified_Array (Day_as_Name)   and
         Tokens_Specified_Array (Day_as_Number) and
         Compute_Day_of_Week (CALENDAR.TIME_OF (Year, Month, Day,
           Seconds)) /= Day_Name then
        raise Day_Date_Error;
      end if;

      -- Make sure that if a special format token was specified, that
      -- the date was not also specified.

      if (Tokens_Specified_Array (Special_Format))      and
         (Tokens_Specified_Array (Day_as_Name)           or
          Tokens_Specified_Array (Day_as_Number)         or
          Tokens_Specified_Array (Month_Name_or_Number)  or
          Tokens_Specified_Array (Year_Number)) then
        raise External_Representation_Error;
      end if;

      -- Make sure that if any part of a date token was specified, that
      -- at least the day number and month were specified.

      if Tokens_Specified_Array (Day_as_Number)              and
         (not Tokens_Specified_Array (Month_Name_or_Number)) then
        raise Month_Missing_Error;
      elsif Tokens_Specified_Array (Month_Name_or_Number)    and
            (not Tokens_Specified_Array (Day_as_Number)) then
        raise Day_Number_Missing_Error;
      elsif Tokens_Specified_Array (Year_Number)             and
            ((not Tokens_Specified_Array (Month_Name_or_Number)) or
             (not Tokens_Specified_Array (Day_as_Number))) then
        raise External_Representation_Error;
      end if;

      -- Now set the internal time if a date or time token was found.

      if Tokens_Specified_Array (Day_as_Number) or
         Tokens_Specified_Array (Time_String) then
        Return_Time_Value := CALENDAR.TIME_OF (Year, Month, Day, Seconds);
      end if;

      -- If the day name was specified without a date, then compute the
      -- current or next future internal time format as of that day.

      if Tokens_Specified_Array (Day_as_Name) and
         (not Tokens_Specified_Array (Day_as_Number)) then
        Compute_Current_or_Next_Future_Date_For_a_Day_Name;
      end if;
    end Perform_Error_Checking_and_Wrap_Up_Loose_Ends;
  begin  -- Convert
    -- Check for a null array... let's not deal with it.

    if Tod_Value'LENGTH = 0 then
      raise External_Representation_Error;
    end if;

    -- Compress the external representation, that is, eliminate all
    -- unnecessary blanks and/or commas.  Then convert all lower case
    -- letters to upper case.

    Compress_External_Representation (Tod_Value, Tod_Value_Compressed_Length);
    Convert_External_Representation_to_Upper_Case (Tod_Value);

    if Tod_Value_Compressed_Length < Minimum_Tod_String_Length then
      raise External_Representation_Error;
    end if;

    -- Now loop on all tokens in the external representation.  Analyze
    -- and process each token.  Some error checking may be needed
    -- after all tokens are found.

    loop
      Grab_a_Token (Tod_Value, Tod_Value_Pointer, Token, Token_Length,
        No_Token_Found);

      exit when No_Token_Found;

      Analyze_and_Process_Token (Token, Token_Length, FALSE);
    end loop;

    -- Now perform special error checking and wrap up loose ends.

    Perform_Error_Checking_and_Wrap_Up_Loose_Ends;

    -- Now return the CALENDAR.TIME internal representation.  If
    -- during the processing, CALENDAR.TIME_ERROR was raised, then
    -- we trap it and send back Date_Error.  If any other exception
    -- was raised, we do nothing and instead let the caller handle it.

    return Return_Time_Value;
  exception
    when CALENDAR.TIME_ERROR => raise Date_Error;
  end Convert;
end Tod_Utilities;